This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove stale date.
[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
NC
449 if (SvMAGICAL(hv)) {
450 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
451 {
452 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
453 sv = sv_newmortal();
113738bb 454
7f66fda2
NC
455 /* XXX should be able to skimp on the HE/HEK here when
456 HV_FETCH_JUST_SV is true. */
113738bb 457
7f66fda2
NC
458 if (!keysv) {
459 keysv = newSVpvn(key, klen);
460 if (is_utf8) {
461 SvUTF8_on(keysv);
462 }
463 } else {
464 keysv = newSVsv(keysv);
113738bb 465 }
7f66fda2
NC
466 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
467
468 /* grab a fake HE/HEK pair from the pool or make a new one */
469 entry = PL_hv_fetch_ent_mh;
470 if (entry)
471 PL_hv_fetch_ent_mh = HeNEXT(entry);
472 else {
473 char *k;
474 entry = new_HE();
a02a5408 475 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
7f66fda2
NC
476 HeKEY_hek(entry) = (HEK*)k;
477 }
478 HeNEXT(entry) = Nullhe;
479 HeSVKEY_set(entry, keysv);
480 HeVAL(entry) = sv;
481 sv_upgrade(sv, SVt_PVLV);
482 LvTYPE(sv) = 'T';
483 /* so we can free entry when freeing sv */
484 LvTARG(sv) = (SV*)entry;
485
486 /* XXX remove at some point? */
487 if (flags & HVhek_FREEKEY)
488 Safefree(key);
489
490 return entry;
113738bb 491 }
7f66fda2
NC
492#ifdef ENV_IS_CASELESS
493 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
494 U32 i;
495 for (i = 0; i < klen; ++i)
496 if (isLOWER(key[i])) {
086cb327
NC
497 /* Would be nice if we had a routine to do the
498 copy and upercase in a single pass through. */
0bd48802 499 const char * const nkey = strupr(savepvn(key,klen));
086cb327
NC
500 /* Note that this fetch is for nkey (the uppercased
501 key) whereas the store is for key (the original) */
502 entry = hv_fetch_common(hv, Nullsv, nkey, klen,
503 HVhek_FREEKEY, /* free nkey */
504 0 /* non-LVAL fetch */,
505 Nullsv /* no value */,
506 0 /* compute hash */);
507 if (!entry && (action & HV_FETCH_LVALUE)) {
508 /* This call will free key if necessary.
509 Do it this way to encourage compiler to tail
510 call optimise. */
511 entry = hv_fetch_common(hv, keysv, key, klen,
512 flags, HV_FETCH_ISSTORE,
513 NEWSV(61,0), hash);
514 } else {
515 if (flags & HVhek_FREEKEY)
516 Safefree(key);
517 }
518 return entry;
7f66fda2 519 }
902173a3 520 }
7f66fda2
NC
521#endif
522 } /* ISFETCH */
523 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
524 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
b2c64049
NC
525 /* I don't understand why hv_exists_ent has svret and sv,
526 whereas hv_exists only had one. */
9d4ba2ae 527 SV * const svret = sv_newmortal();
b2c64049 528 sv = sv_newmortal();
7f66fda2
NC
529
530 if (keysv || is_utf8) {
531 if (!keysv) {
532 keysv = newSVpvn(key, klen);
533 SvUTF8_on(keysv);
534 } else {
535 keysv = newSVsv(keysv);
536 }
b2c64049
NC
537 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
538 } else {
539 mg_copy((SV*)hv, sv, key, klen);
7f66fda2 540 }
b2c64049
NC
541 if (flags & HVhek_FREEKEY)
542 Safefree(key);
7f66fda2
NC
543 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
544 /* This cast somewhat evil, but I'm merely using NULL/
545 not NULL to return the boolean exists.
546 And I know hv is not NULL. */
547 return SvTRUE(svret) ? (HE *)hv : NULL;
e7152ba2 548 }
7f66fda2
NC
549#ifdef ENV_IS_CASELESS
550 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
551 /* XXX This code isn't UTF8 clean. */
a15d23f8 552 char * const keysave = (char * const)key;
b2c64049
NC
553 /* Will need to free this, so set FREEKEY flag. */
554 key = savepvn(key,klen);
555 key = (const char*)strupr((char*)key);
7f66fda2
NC
556 is_utf8 = 0;
557 hash = 0;
8b4f7dd5 558 keysv = 0;
b2c64049
NC
559
560 if (flags & HVhek_FREEKEY) {
561 Safefree(keysave);
562 }
563 flags |= HVhek_FREEKEY;
7f66fda2 564 }
902173a3 565#endif
7f66fda2 566 } /* ISEXISTS */
b2c64049
NC
567 else if (action & HV_FETCH_ISSTORE) {
568 bool needs_copy;
569 bool needs_store;
570 hv_magic_check (hv, &needs_copy, &needs_store);
571 if (needs_copy) {
a3b680e6 572 const bool save_taint = PL_tainted;
b2c64049
NC
573 if (keysv || is_utf8) {
574 if (!keysv) {
575 keysv = newSVpvn(key, klen);
576 SvUTF8_on(keysv);
577 }
578 if (PL_tainting)
579 PL_tainted = SvTAINTED(keysv);
580 keysv = sv_2mortal(newSVsv(keysv));
581 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
582 } else {
583 mg_copy((SV*)hv, val, key, klen);
584 }
585
586 TAINT_IF(save_taint);
7b2c381c 587 if (!HvARRAY(hv) && !needs_store) {
b2c64049
NC
588 if (flags & HVhek_FREEKEY)
589 Safefree(key);
590 return Nullhe;
591 }
592#ifdef ENV_IS_CASELESS
593 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
594 /* XXX This code isn't UTF8 clean. */
595 const char *keysave = key;
596 /* Will need to free this, so set FREEKEY flag. */
597 key = savepvn(key,klen);
598 key = (const char*)strupr((char*)key);
599 is_utf8 = 0;
600 hash = 0;
8b4f7dd5 601 keysv = 0;
b2c64049
NC
602
603 if (flags & HVhek_FREEKEY) {
604 Safefree(keysave);
605 }
606 flags |= HVhek_FREEKEY;
607 }
608#endif
609 }
610 } /* ISSTORE */
7f66fda2 611 } /* SvMAGICAL */
fde52b5c 612
7b2c381c 613 if (!HvARRAY(hv)) {
b2c64049 614 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
fde52b5c 615#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
8aacddc1 616 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
fde52b5c 617#endif
d58e6666
NC
618 ) {
619 char *array;
a02a5408 620 Newxz(array,
cbec9347 621 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
d58e6666
NC
622 char);
623 HvARRAY(hv) = (HE**)array;
624 }
7f66fda2
NC
625#ifdef DYNAMIC_ENV_FETCH
626 else if (action & HV_FETCH_ISEXISTS) {
627 /* for an %ENV exists, if we do an insert it's by a recursive
628 store call, so avoid creating HvARRAY(hv) right now. */
629 }
630#endif
113738bb
NC
631 else {
632 /* XXX remove at some point? */
633 if (flags & HVhek_FREEKEY)
634 Safefree(key);
635
fde52b5c 636 return 0;
113738bb 637 }
fde52b5c
PP
638 }
639
19692e8d 640 if (is_utf8) {
a15d23f8 641 char * const keysave = (char * const)key;
f9a63242 642 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
19692e8d 643 if (is_utf8)
c1fe5510
NC
644 flags |= HVhek_UTF8;
645 else
646 flags &= ~HVhek_UTF8;
7f66fda2
NC
647 if (key != keysave) {
648 if (flags & HVhek_FREEKEY)
649 Safefree(keysave);
19692e8d 650 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
7f66fda2 651 }
19692e8d 652 }
f9a63242 653
4b5190b5
NC
654 if (HvREHASH(hv)) {
655 PERL_HASH_INTERNAL(hash, key, klen);
b2c64049
NC
656 /* We don't have a pointer to the hv, so we have to replicate the
657 flag into every HEK, so that hv_iterkeysv can see it. */
658 /* And yes, you do need this even though you are not "storing" because
fdcd69b6
NC
659 you can flip the flags below if doing an lval lookup. (And that
660 was put in to give the semantics Andreas was expecting.) */
661 flags |= HVhek_REHASH;
4b5190b5 662 } else if (!hash) {
113738bb 663 if (keysv && (SvIsCOW_shared_hash(keysv))) {
c158a4fd 664 hash = SvSHARED_HASH(keysv);
46187eeb
NC
665 } else {
666 PERL_HASH(hash, key, klen);
667 }
668 }
effa1e2d 669
113738bb
NC
670 masked_flags = (flags & HVhek_MASK);
671
7f66fda2 672#ifdef DYNAMIC_ENV_FETCH
7b2c381c 673 if (!HvARRAY(hv)) entry = Null(HE*);
7f66fda2
NC
674 else
675#endif
b2c64049 676 {
7b2c381c 677 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
b2c64049 678 }
0298d7b9 679 for (; entry; entry = HeNEXT(entry)) {
fde52b5c
PP
680 if (HeHASH(entry) != hash) /* strings can't be equal */
681 continue;
eb160463 682 if (HeKLEN(entry) != (I32)klen)
fde52b5c 683 continue;
1c846c1f 684 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 685 continue;
113738bb 686 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 687 continue;
b2c64049
NC
688
689 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
690 if (HeKFLAGS(entry) != masked_flags) {
691 /* We match if HVhek_UTF8 bit in our flags and hash key's
692 match. But if entry was set previously with HVhek_WASUTF8
693 and key now doesn't (or vice versa) then we should change
694 the key's flag, as this is assignment. */
695 if (HvSHAREKEYS(hv)) {
696 /* Need to swap the key we have for a key with the flags we
697 need. As keys are shared we can't just write to the
698 flag, so we share the new one, unshare the old one. */
6e838c70
NC
699 HEK *new_hek = share_hek_flags(key, klen, hash,
700 masked_flags);
b2c64049
NC
701 unshare_hek (HeKEY_hek(entry));
702 HeKEY_hek(entry) = new_hek;
703 }
5d2b1485
NC
704 else if (hv == PL_strtab) {
705 /* PL_strtab is usually the only hash without HvSHAREKEYS,
706 so putting this test here is cheap */
707 if (flags & HVhek_FREEKEY)
708 Safefree(key);
709 Perl_croak(aTHX_ S_strtab_error,
710 action & HV_FETCH_LVALUE ? "fetch" : "store");
711 }
b2c64049
NC
712 else
713 HeKFLAGS(entry) = masked_flags;
714 if (masked_flags & HVhek_ENABLEHVKFLAGS)
715 HvHASKFLAGS_on(hv);
716 }
717 if (HeVAL(entry) == &PL_sv_placeholder) {
718 /* yes, can store into placeholder slot */
719 if (action & HV_FETCH_LVALUE) {
720 if (SvMAGICAL(hv)) {
721 /* This preserves behaviour with the old hv_fetch
722 implementation which at this point would bail out
723 with a break; (at "if we find a placeholder, we
724 pretend we haven't found anything")
725
726 That break mean that if a placeholder were found, it
727 caused a call into hv_store, which in turn would
728 check magic, and if there is no magic end up pretty
729 much back at this point (in hv_store's code). */
730 break;
731 }
732 /* LVAL fetch which actaully needs a store. */
733 val = NEWSV(61,0);
ca732855 734 HvPLACEHOLDERS(hv)--;
b2c64049
NC
735 } else {
736 /* store */
737 if (val != &PL_sv_placeholder)
ca732855 738 HvPLACEHOLDERS(hv)--;
b2c64049
NC
739 }
740 HeVAL(entry) = val;
741 } else if (action & HV_FETCH_ISSTORE) {
742 SvREFCNT_dec(HeVAL(entry));
743 HeVAL(entry) = val;
744 }
27bcc0a7 745 } else if (HeVAL(entry) == &PL_sv_placeholder) {
b2c64049
NC
746 /* if we find a placeholder, we pretend we haven't found
747 anything */
8aacddc1 748 break;
b2c64049 749 }
113738bb
NC
750 if (flags & HVhek_FREEKEY)
751 Safefree(key);
fde52b5c
PP
752 return entry;
753 }
754#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
0ed29950
NC
755 if (!(action & HV_FETCH_ISSTORE)
756 && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364 757 unsigned long len;
9d4ba2ae 758 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
a6c40364
GS
759 if (env) {
760 sv = newSVpvn(env,len);
761 SvTAINTED_on(sv);
7fd3d16e 762 return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
b2c64049 763 hash);
a6c40364 764 }
fde52b5c
PP
765 }
766#endif
7f66fda2
NC
767
768 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
c445ea15 769 hv_notallowed(flags, key, klen,
c8cd6465
NC
770 "Attempt to access disallowed key '%"SVf"' in"
771 " a restricted hash");
1b1f1335 772 }
b2c64049
NC
773 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
774 /* Not doing some form of store, so return failure. */
775 if (flags & HVhek_FREEKEY)
776 Safefree(key);
777 return 0;
778 }
113738bb 779 if (action & HV_FETCH_LVALUE) {
b2c64049
NC
780 val = NEWSV(61,0);
781 if (SvMAGICAL(hv)) {
782 /* At this point the old hv_fetch code would call to hv_store,
783 which in turn might do some tied magic. So we need to make that
784 magic check happen. */
785 /* gonna assign to this, so it better be there */
786 return hv_fetch_common(hv, keysv, key, klen, flags,
787 HV_FETCH_ISSTORE, val, hash);
788 /* XXX Surely that could leak if the fetch-was-store fails?
789 Just like the hv_fetch. */
113738bb
NC
790 }
791 }
792
b2c64049
NC
793 /* Welcome to hv_store... */
794
7b2c381c 795 if (!HvARRAY(hv)) {
b2c64049
NC
796 /* Not sure if we can get here. I think the only case of oentry being
797 NULL is for %ENV with dynamic env fetch. But that should disappear
798 with magic in the previous code. */
d58e6666 799 char *array;
a02a5408 800 Newxz(array,
b2c64049 801 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
d58e6666
NC
802 char);
803 HvARRAY(hv) = (HE**)array;
b2c64049
NC
804 }
805
7b2c381c 806 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
ab4af705 807
b2c64049
NC
808 entry = new_HE();
809 /* share_hek_flags will do the free for us. This might be considered
810 bad API design. */
811 if (HvSHAREKEYS(hv))
6e838c70 812 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
5d2b1485
NC
813 else if (hv == PL_strtab) {
814 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
815 this test here is cheap */
816 if (flags & HVhek_FREEKEY)
817 Safefree(key);
818 Perl_croak(aTHX_ S_strtab_error,
819 action & HV_FETCH_LVALUE ? "fetch" : "store");
820 }
b2c64049
NC
821 else /* gotta do the real thing */
822 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
823 HeVAL(entry) = val;
824 HeNEXT(entry) = *oentry;
825 *oentry = entry;
826
827 if (val == &PL_sv_placeholder)
ca732855 828 HvPLACEHOLDERS(hv)++;
b2c64049
NC
829 if (masked_flags & HVhek_ENABLEHVKFLAGS)
830 HvHASKFLAGS_on(hv);
831
0298d7b9
NC
832 {
833 const HE *counter = HeNEXT(entry);
834
835 xhv->xhv_keys++; /* HvKEYS(hv)++ */
836 if (!counter) { /* initial entry? */
837 xhv->xhv_fill++; /* HvFILL(hv)++ */
838 } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
839 hsplit(hv);
840 } else if(!HvREHASH(hv)) {
841 U32 n_links = 1;
842
843 while ((counter = HeNEXT(counter)))
844 n_links++;
845
846 if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
847 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
848 bucket splits on a rehashed hash, as we're not going to
849 split it again, and if someone is lucky (evil) enough to
850 get all the keys in one list they could exhaust our memory
851 as we repeatedly double the number of buckets on every
852 entry. Linear search feels a less worse thing to do. */
853 hsplit(hv);
854 }
855 }
fde52b5c 856 }
b2c64049
NC
857
858 return entry;
fde52b5c
PP
859}
860
864dbfa3 861STATIC void
cea2e8a9 862S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
d0066dc7 863{
a3b680e6 864 const MAGIC *mg = SvMAGIC(hv);
d0066dc7
OT
865 *needs_copy = FALSE;
866 *needs_store = TRUE;
867 while (mg) {
868 if (isUPPER(mg->mg_type)) {
869 *needs_copy = TRUE;
d60c5a05 870 if (mg->mg_type == PERL_MAGIC_tied) {
d0066dc7 871 *needs_store = FALSE;
4ab2a30b 872 return; /* We've set all there is to set. */
d0066dc7
OT
873 }
874 }
875 mg = mg->mg_moremagic;
876 }
877}
878
954c1994 879/*
a3bcc51e
TP
880=for apidoc hv_scalar
881
882Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
883
884=cut
885*/
886
887SV *
888Perl_hv_scalar(pTHX_ HV *hv)
889{
a3bcc51e 890 SV *sv;
823a54a3
AL
891
892 if (SvRMAGICAL(hv)) {
893 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
894 if (mg)
895 return magic_scalarpack(hv, mg);
896 }
a3bcc51e
TP
897
898 sv = sv_newmortal();
899 if (HvFILL((HV*)hv))
900 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
901 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
902 else
903 sv_setiv(sv, 0);
904
905 return sv;
906}
907
908/*
954c1994
GS
909=for apidoc hv_delete
910
911Deletes a key/value pair in the hash. The value SV is removed from the
1c846c1f 912hash and returned to the caller. The C<klen> is the length of the key.
954c1994
GS
913The C<flags> value will normally be zero; if set to G_DISCARD then NULL
914will be returned.
915
916=cut
917*/
918
79072805 919SV *
cd6d36ac 920Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
79072805 921{
cd6d36ac
NC
922 STRLEN klen;
923 int k_flags = 0;
924
925 if (klen_i32 < 0) {
926 klen = -klen_i32;
927 k_flags |= HVhek_UTF8;
928 } else {
929 klen = klen_i32;
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;
fde52b5c 961 SV *sv;
da58a35d 962 bool is_utf8;
7a9669ca 963 int masked_flags;
1c846c1f 964
fde52b5c
PP
965 if (!hv)
966 return Nullsv;
f1317c8d
NC
967
968 if (keysv) {
e593d2fe
AE
969 if (k_flags & HVhek_FREEKEY)
970 Safefree(key);
5c144d81 971 key = SvPV_const(keysv, klen);
cd6d36ac 972 k_flags = 0;
f1317c8d
NC
973 is_utf8 = (SvUTF8(keysv) != 0);
974 } else {
cd6d36ac 975 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
f1317c8d 976 }
f1317c8d 977
fde52b5c 978 if (SvRMAGICAL(hv)) {
0a0bb7c7
OT
979 bool needs_copy;
980 bool needs_store;
981 hv_magic_check (hv, &needs_copy, &needs_store);
982
f1317c8d 983 if (needs_copy) {
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) {
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.... */
7996736c 1070 if (HeVAL(entry) == &PL_sv_placeholder)
8aacddc1 1071 {
b84d0860
NC
1072 if (k_flags & HVhek_FREEKEY)
1073 Safefree(key);
1074 return Nullsv;
8aacddc1
NIS
1075 }
1076 else 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) {
a3b680e6 1371 register I32 j;
72940dca
PP
1372 if ((j = (HeHASH(entry) & newsize)) != i) {
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;
9d4ba2ae 1400 HV * const hv = (HV*)NEWSV(502,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++) {
aec46f14
AL
1436 HE *prev = NULL, *ent = NULL;
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);
b56ba0bf
AMS
1450
1451 ent = new_HE();
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
JH
1559 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1560 SV* keysv = hv_iterkeysv(entry);
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 */
a3b680e6 1618 bool first = 1;
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);
1642 first = 0;
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) */
1683 HE **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 */
1721 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
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 }
1773 };
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);
51a37f80 1810 hv_name_set(hv, Nullch, 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*
b79f7545 1823S_hv_auxinit(pTHX_ 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 */
1841 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
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
NC
1868 if (SvOOK(hv)) {
1869 struct xpvhv_aux *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 */
1876 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1877 } else {
b79f7545 1878 S_hv_auxinit(aTHX_ 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
b79f7545 1892 iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ 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
b79f7545 1903 iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ 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
b79f7545 1920 iter = S_hv_auxinit(aTHX_ 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
b79f7545 1940 iter = S_hv_auxinit(aTHX_ hv);
bfcb3514
NC
1941 }
1942 iter->xhv_eiter = eiter;
1943}
1944
bfcb3514 1945void
7423f6db 1946Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int 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
b79f7545
NC
1954 if (SvOOK(hv)) {
1955 iter = HvAUX(hv);
7423f6db
NC
1956 if (iter->xhv_name) {
1957 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1958 }
16580ff5 1959 } else {
bfcb3514
NC
1960 if (name == 0)
1961 return;
1962
b79f7545 1963 iter = S_hv_auxinit(aTHX_ hv);
bfcb3514 1964 }
7423f6db
NC
1965 PERL_HASH(hash, name, len);
1966 iter->xhv_name = name ? share_hek(name, len, hash) : 0;
bfcb3514
NC
1967}
1968
86f55936
NC
1969AV **
1970Perl_hv_backreferences_p(pTHX_ HV *hv) {
1971 struct xpvhv_aux *iter;
1972
1973 iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv);
1974 return &(iter->xhv_backreferences);
1975}
1976
1977void
1978Perl_hv_kill_backrefs(pTHX_ HV *hv) {
1979 AV *av;
1980
1981 if (!SvOOK(hv))
1982 return;
1983
1984 av = HvAUX(hv)->xhv_backreferences;
1985
1986 if (av) {
1987 HvAUX(hv)->xhv_backreferences = 0;
1988 Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av);
1989 }
1990}
1991
954c1994 1992/*
7a7b9979
NC
1993hv_iternext is implemented as a macro in hv.h
1994
954c1994
GS
1995=for apidoc hv_iternext
1996
1997Returns entries from a hash iterator. See C<hv_iterinit>.
1998
fe7bca90
NC
1999You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2000iterator currently points to, without losing your place or invalidating your
2001iterator. Note that in this case the current entry is deleted from the hash
2002with your iterator holding the last reference to it. Your iterator is flagged
2003to free the entry on the next call to C<hv_iternext>, so you must not discard
2004your iterator immediately else the entry will leak - call C<hv_iternext> to
2005trigger the resource deallocation.
2006
fe7bca90
NC
2007=for apidoc hv_iternext_flags
2008
2009Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2010The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2011set the placeholders keys (for restricted hashes) will be returned in addition
2012to normal keys. By default placeholders are automatically skipped over.
7996736c
MHM
2013Currently a placeholder is implemented with a value that is
2014C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
fe7bca90
NC
2015restricted hashes may change, and the implementation currently is
2016insufficiently abstracted for any change to be tidy.
e16e2ff8 2017
fe7bca90 2018=cut
e16e2ff8
NC
2019*/
2020
2021HE *
2022Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2023{
27da23d5 2024 dVAR;
cbec9347 2025 register XPVHV* xhv;
79072805 2026 register HE *entry;
a0d0e21e 2027 HE *oldentry;
463ee0b2 2028 MAGIC* mg;
bfcb3514 2029 struct xpvhv_aux *iter;
79072805
LW
2030
2031 if (!hv)
cea2e8a9 2032 Perl_croak(aTHX_ "Bad hash");
cbec9347 2033 xhv = (XPVHV*)SvANY(hv);
bfcb3514 2034
b79f7545 2035 if (!SvOOK(hv)) {
bfcb3514
NC
2036 /* Too many things (well, pp_each at least) merrily assume that you can
2037 call iv_iternext without calling hv_iterinit, so we'll have to deal
2038 with it. */
2039 hv_iterinit(hv);
bfcb3514 2040 }
b79f7545 2041 iter = HvAUX(hv);
bfcb3514
NC
2042
2043 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
463ee0b2 2044
14befaf4 2045 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
c4420975 2046 SV * const key = sv_newmortal();
cd1469e6 2047 if (entry) {
fde52b5c 2048 sv_setsv(key, HeSVKEY_force(entry));
cd1469e6
PP
2049 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2050 }
a0d0e21e 2051 else {
ff68c719 2052 char *k;
bbce6d69 2053 HEK *hek;
ff68c719 2054
cbec9347 2055 /* one HE per MAGICAL hash */
bfcb3514 2056 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
4633a7c4 2057 Zero(entry, 1, HE);
a02a5408 2058 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
ff68c719
PP
2059 hek = (HEK*)k;
2060 HeKEY_hek(entry) = hek;
fde52b5c 2061 HeKLEN(entry) = HEf_SVKEY;
a0d0e21e
LW
2062 }
2063 magic_nextpack((SV*) hv,mg,key);
8aacddc1 2064 if (SvOK(key)) {
cd1469e6 2065 /* force key to stay around until next time */
bbce6d69
PP
2066 HeSVKEY_set(entry, SvREFCNT_inc(key));
2067 return entry; /* beware, hent_val is not set */
8aacddc1 2068 }
fde52b5c
PP
2069 if (HeVAL(entry))
2070 SvREFCNT_dec(HeVAL(entry));
ff68c719 2071 Safefree(HeKEY_hek(entry));
d33b2eba 2072 del_HE(entry);
bfcb3514 2073 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
463ee0b2 2074 return Null(HE*);
79072805 2075 }
f675dbe5 2076#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
03026e68 2077 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
f675dbe5 2078 prime_env_iter();
03026e68
JM
2079#ifdef VMS
2080 /* The prime_env_iter() on VMS just loaded up new hash values
2081 * so the iteration count needs to be reset back to the beginning
2082 */
2083 hv_iterinit(hv);
2084 iter = HvAUX(hv);
2085 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2086#endif
2087 }
f675dbe5 2088#endif
463ee0b2 2089
b79f7545
NC
2090 /* hv_iterint now ensures this. */
2091 assert (HvARRAY(hv));
2092
015a5f36 2093 /* At start of hash, entry is NULL. */
fde52b5c 2094 if (entry)
8aacddc1 2095 {
fde52b5c 2096 entry = HeNEXT(entry);
e16e2ff8
NC
2097 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2098 /*
2099 * Skip past any placeholders -- don't want to include them in
2100 * any iteration.
2101 */
7996736c 2102 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
e16e2ff8
NC
2103 entry = HeNEXT(entry);
2104 }
8aacddc1
NIS
2105 }
2106 }
fde52b5c 2107 while (!entry) {
015a5f36
NC
2108 /* OK. Come to the end of the current list. Grab the next one. */
2109
bfcb3514
NC
2110 iter->xhv_riter++; /* HvRITER(hv)++ */
2111 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
015a5f36 2112 /* There is no next one. End of the hash. */
bfcb3514 2113 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
fde52b5c 2114 break;
79072805 2115 }
7b2c381c 2116 entry = (HvARRAY(hv))[iter->xhv_riter];
8aacddc1 2117
e16e2ff8 2118 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
015a5f36
NC
2119 /* If we have an entry, but it's a placeholder, don't count it.
2120 Try the next. */
7996736c 2121 while (entry && HeVAL(entry) == &PL_sv_placeholder)
015a5f36
NC
2122 entry = HeNEXT(entry);
2123 }
2124 /* Will loop again if this linked list starts NULL
2125 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2126 or if we run through it and find only placeholders. */
fde52b5c 2127 }
79072805 2128
72940dca
PP
2129 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2130 HvLAZYDEL_off(hv);
68dc0745 2131 hv_free_ent(hv, oldentry);
72940dca 2132 }
a0d0e21e 2133
fdcd69b6
NC
2134 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2135 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2136
bfcb3514 2137 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
79072805
LW
2138 return entry;
2139}
2140
954c1994
GS
2141/*
2142=for apidoc hv_iterkey
2143
2144Returns the key from the current position of the hash iterator. See
2145C<hv_iterinit>.
2146
2147=cut
2148*/
2149
79072805 2150char *
864dbfa3 2151Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 2152{
fde52b5c 2153 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a 2154 STRLEN len;
0bd48802 2155 char * const p = SvPV(HeKEY_sv(entry), len);
fb73857a
PP
2156 *retlen = len;
2157 return p;
fde52b5c
PP
2158 }
2159 else {
2160 *retlen = HeKLEN(entry);
2161 return HeKEY(entry);
2162 }
2163}
2164
2165/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994
GS
2166/*
2167=for apidoc hv_iterkeysv
2168
2169Returns the key as an C<SV*> from the current position of the hash
2170iterator. The return value will always be a mortal copy of the key. Also
2171see C<hv_iterinit>.
2172
2173=cut
2174*/
2175
fde52b5c 2176SV *
864dbfa3 2177Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 2178{
c1b02ed8 2179 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
79072805
LW
2180}
2181
954c1994
GS
2182/*
2183=for apidoc hv_iterval
2184
2185Returns the value from the current position of the hash iterator. See
2186C<hv_iterkey>.
2187
2188=cut
2189*/
2190
79072805 2191SV *
864dbfa3 2192Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 2193{
8990e307 2194 if (SvRMAGICAL(hv)) {
14befaf4 2195 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
c4420975 2196 SV* const sv = sv_newmortal();
bbce6d69
PP
2197 if (HeKLEN(entry) == HEf_SVKEY)
2198 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
a3b680e6
AL
2199 else
2200 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2
LW
2201 return sv;
2202 }
79072805 2203 }
fde52b5c 2204 return HeVAL(entry);
79072805
LW
2205}
2206
954c1994
GS
2207/*
2208=for apidoc hv_iternextsv
2209
2210Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2211operation.
2212
2213=cut
2214*/
2215
a0d0e21e 2216SV *
864dbfa3 2217Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e 2218{
0bd48802
AL
2219 HE * const he = hv_iternext_flags(hv, 0);
2220
2221 if (!he)
a0d0e21e
LW
2222 return NULL;
2223 *key = hv_iterkey(he, retlen);
2224 return hv_iterval(hv, he);
2225}
2226
954c1994 2227/*
bc5cdc23
NC
2228
2229Now a macro in hv.h
2230
954c1994
GS
2231=for apidoc hv_magic
2232
2233Adds magic to a hash. See C<sv_magic>.
2234
2235=cut
2236*/
2237
bbce6d69 2238/* possibly free a shared string if no one has access to it
fde52b5c
PP
2239 * len and hash must both be valid for str.
2240 */
bbce6d69 2241void
864dbfa3 2242Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 2243{
19692e8d
NC
2244 unshare_hek_or_pvn (NULL, str, len, hash);
2245}
2246
2247
2248void
2249Perl_unshare_hek(pTHX_ HEK *hek)
2250{
2251 unshare_hek_or_pvn(hek, NULL, 0, 0);
2252}
2253
2254/* possibly free a shared string if no one has access to it
2255 hek if non-NULL takes priority over the other 3, else str, len and hash
2256 are used. If so, len and hash must both be valid for str.
2257 */
df132699 2258STATIC void
97ddebaf 2259S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
19692e8d 2260{
97aff369 2261 dVAR;
cbec9347 2262 register XPVHV* xhv;
20454177 2263 HE *entry;
fde52b5c 2264 register HE **oentry;
45d1cc86 2265 HE **first;
a3b680e6 2266 bool found = 0;
c3654f1a 2267 bool is_utf8 = FALSE;
19692e8d 2268 int k_flags = 0;
aec46f14 2269 const char * const save = str;
cbbf8932 2270 struct shared_he *he = NULL;
c3654f1a 2271
19692e8d 2272 if (hek) {
cbae3960
NC
2273 /* Find the shared he which is just before us in memory. */
2274 he = (struct shared_he *)(((char *)hek)
2275 - STRUCT_OFFSET(struct shared_he,
2276 shared_he_hek));
2277
2278 /* Assert that the caller passed us a genuine (or at least consistent)
2279 shared hek */
2280 assert (he->shared_he_he.hent_hek == hek);
29404ae0
NC
2281
2282 LOCK_STRTAB_MUTEX;
2283 if (he->shared_he_he.hent_val - 1) {
2284 --he->shared_he_he.hent_val;
2285 UNLOCK_STRTAB_MUTEX;
2286 return;
2287 }
2288 UNLOCK_STRTAB_MUTEX;
2289
19692e8d
NC
2290 hash = HEK_HASH(hek);
2291 } else if (len < 0) {
2292 STRLEN tmplen = -len;
2293 is_utf8 = TRUE;
2294 /* See the note in hv_fetch(). --jhi */
2295 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2296 len = tmplen;
2297 if (is_utf8)
2298 k_flags = HVhek_UTF8;
2299 if (str != save)
2300 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
c3654f1a 2301 }
1c846c1f 2302
fde52b5c 2303 /* what follows is the moral equivalent of:
6b88bc9c 2304 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
bbce6d69 2305 if (--*Svp == Nullsv)
6b88bc9c 2306 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 2307 } */
cbec9347 2308 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2309 /* assert(xhv_array != 0) */
5f08fbcd 2310 LOCK_STRTAB_MUTEX;
45d1cc86 2311 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
6c1b96a1
NC
2312 if (he) {
2313 const HE *const he_he = &(he->shared_he_he);
45d1cc86 2314 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
6c1b96a1 2315 if (entry != he_he)
19692e8d
NC
2316 continue;
2317 found = 1;
2318 break;
2319 }
2320 } else {
35a4481c 2321 const int flags_masked = k_flags & HVhek_MASK;
45d1cc86 2322 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
19692e8d
NC
2323 if (HeHASH(entry) != hash) /* strings can't be equal */
2324 continue;
2325 if (HeKLEN(entry) != len)
2326 continue;
2327 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2328 continue;
2329 if (HeKFLAGS(entry) != flags_masked)
2330 continue;
2331 found = 1;
2332 break;
2333 }
2334 }
2335
2336 if (found) {
2337 if (--HeVAL(entry) == Nullsv) {
2338 *oentry = HeNEXT(entry);
45d1cc86
NC
2339 if (!*first) {
2340 /* There are now no entries in our slot. */
19692e8d 2341 xhv->xhv_fill--; /* HvFILL(hv)-- */
45d1cc86 2342 }
cbae3960 2343 Safefree(entry);
19692e8d
NC
2344 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2345 }
fde52b5c 2346 }
19692e8d 2347
333f433b 2348 UNLOCK_STRTAB_MUTEX;
411caa50 2349 if (!found && ckWARN_d(WARN_INTERNAL))
19692e8d 2350 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB
2351 "Attempt to free non-existent shared string '%s'%s"
2352 pTHX__FORMAT,
19692e8d 2353 hek ? HEK_KEY(hek) : str,
472d47bc 2354 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
19692e8d
NC
2355 if (k_flags & HVhek_FREEKEY)
2356 Safefree(str);
fde52b5c
PP
2357}
2358
bbce6d69
PP
2359/* get a (constant) string ptr from the global string table
2360 * string will get added if it is not already there.
fde52b5c
PP
2361 * len and hash must both be valid for str.
2362 */
bbce6d69 2363HEK *
864dbfa3 2364Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 2365{
da58a35d 2366 bool is_utf8 = FALSE;
19692e8d 2367 int flags = 0;
aec46f14 2368 const char * const save = str;
da58a35d
JH
2369
2370 if (len < 0) {
77caf834 2371 STRLEN tmplen = -len;
da58a35d 2372 is_utf8 = TRUE;
77caf834
JH
2373 /* See the note in hv_fetch(). --jhi */
2374 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2375 len = tmplen;
19692e8d
NC
2376 /* If we were able to downgrade here, then than means that we were passed
2377 in a key which only had chars 0-255, but was utf8 encoded. */
2378 if (is_utf8)
2379 flags = HVhek_UTF8;
2380 /* If we found we were able to downgrade the string to bytes, then
2381 we should flag that it needs upgrading on keys or each. Also flag
2382 that we need share_hek_flags to free the string. */
2383 if (str != save)
2384 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2385 }
2386
6e838c70 2387 return share_hek_flags (str, len, hash, flags);
19692e8d
NC
2388}
2389
6e838c70 2390STATIC HEK *
19692e8d
NC
2391S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2392{
97aff369 2393 dVAR;
19692e8d 2394 register HE *entry;
35a4481c 2395 const int flags_masked = flags & HVhek_MASK;
263cb4a6 2396 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
bbce6d69 2397
fde52b5c 2398 /* what follows is the moral equivalent of:
1c846c1f 2399
6b88bc9c 2400 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
8aacddc1 2401 hv_store(PL_strtab, str, len, Nullsv, hash);
fdcd69b6
NC
2402
2403 Can't rehash the shared string table, so not sure if it's worth
2404 counting the number of entries in the linked list
bbce6d69 2405 */
1b6737cc 2406 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2407 /* assert(xhv_array != 0) */
5f08fbcd 2408 LOCK_STRTAB_MUTEX;
263cb4a6
NC
2409 entry = (HvARRAY(PL_strtab))[hindex];
2410 for (;entry; entry = HeNEXT(entry)) {
fde52b5c
PP
2411 if (HeHASH(entry) != hash) /* strings can't be equal */
2412 continue;
2413 if (HeKLEN(entry) != len)
2414 continue;
1c846c1f 2415 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 2416 continue;
19692e8d 2417 if (HeKFLAGS(entry) != flags_masked)
c3654f1a 2418 continue;
fde52b5c
PP
2419 break;
2420 }
263cb4a6
NC
2421
2422 if (!entry) {
45d1cc86
NC
2423 /* What used to be head of the list.
2424 If this is NULL, then we're the first entry for this slot, which
2425 means we need to increate fill. */
cbae3960
NC
2426 struct shared_he *new_entry;
2427 HEK *hek;
2428 char *k;
263cb4a6
NC
2429 HE **const head = &HvARRAY(PL_strtab)[hindex];
2430 HE *const next = *head;
cbae3960
NC
2431
2432 /* We don't actually store a HE from the arena and a regular HEK.
2433 Instead we allocate one chunk of memory big enough for both,
2434 and put the HEK straight after the HE. This way we can find the
2435 HEK directly from the HE.
2436 */
2437
a02a5408 2438 Newx(k, STRUCT_OFFSET(struct shared_he,
cbae3960
NC
2439 shared_he_hek.hek_key[0]) + len + 2, char);
2440 new_entry = (struct shared_he *)k;
2441 entry = &(new_entry->shared_he_he);
2442 hek = &(new_entry->shared_he_hek);
2443
2444 Copy(str, HEK_KEY(hek), len, char);
2445 HEK_KEY(hek)[len] = 0;
2446 HEK_LEN(hek) = len;
2447 HEK_HASH(hek) = hash;
2448 HEK_FLAGS(hek) = (unsigned char)flags_masked;
2449
2450 /* Still "point" to the HEK, so that other code need not know what
2451 we're up to. */
2452 HeKEY_hek(entry) = hek;
bbce6d69 2453 HeVAL(entry) = Nullsv;
263cb4a6
NC
2454 HeNEXT(entry) = next;
2455 *head = entry;
cbae3960 2456
cbec9347 2457 xhv->xhv_keys++; /* HvKEYS(hv)++ */
263cb4a6 2458 if (!next) { /* initial entry? */
cbec9347 2459 xhv->xhv_fill++; /* HvFILL(hv)++ */
4c9cc595 2460 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
cbec9347 2461 hsplit(PL_strtab);
bbce6d69
PP
2462 }
2463 }
2464
2465 ++HeVAL(entry); /* use value slot as REFCNT */
5f08fbcd 2466 UNLOCK_STRTAB_MUTEX;
19692e8d
NC
2467
2468 if (flags & HVhek_FREEKEY)
f9a63242 2469 Safefree(str);
19692e8d 2470
6e838c70 2471 return HeKEY_hek(entry);
fde52b5c 2472}
ecae49c0 2473
ca732855
NC
2474I32 *
2475Perl_hv_placeholders_p(pTHX_ HV *hv)
2476{
2477 dVAR;
2478 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2479
2480 if (!mg) {
2481 mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2482
2483 if (!mg) {
2484 Perl_die(aTHX_ "panic: hv_placeholders_p");
2485 }
2486 }
2487 return &(mg->mg_len);
2488}
2489
2490
2491I32
2492Perl_hv_placeholders_get(pTHX_ HV *hv)
2493{
2494 dVAR;
b464bac0 2495 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
ca732855
NC
2496
2497 return mg ? mg->mg_len : 0;
2498}
2499
2500void
ac1e784a 2501Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
ca732855
NC
2502{
2503 dVAR;
b464bac0 2504 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
ca732855
NC
2505
2506 if (mg) {
2507 mg->mg_len = ph;
2508 } else if (ph) {
2509 if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2510 Perl_die(aTHX_ "panic: hv_placeholders_set");
2511 }
2512 /* else we don't need to add magic to record 0 placeholders. */
2513}
ecae49c0
NC
2514
2515/*
2516=for apidoc hv_assert
2517
2518Check that a hash is in an internally consistent state.
2519
2520=cut
2521*/
2522
2523void
2524Perl_hv_assert(pTHX_ HV *hv)
2525{
27da23d5 2526 dVAR;
ecae49c0
NC
2527 HE* entry;
2528 int withflags = 0;
2529 int placeholders = 0;
2530 int real = 0;
2531 int bad = 0;
bfcb3514
NC
2532 const I32 riter = HvRITER_get(hv);
2533 HE *eiter = HvEITER_get(hv);
ecae49c0
NC
2534
2535 (void)hv_iterinit(hv);
2536
2537 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2538 /* sanity check the values */
2539 if (HeVAL(entry) == &PL_sv_placeholder) {
2540 placeholders++;
2541 } else {
2542 real++;
2543 }
2544 /* sanity check the keys */
2545 if (HeSVKEY(entry)) {
2546 /* Don't know what to check on SV keys. */
2547 } else if (HeKUTF8(entry)) {
2548 withflags++;
2549 if (HeKWASUTF8(entry)) {
2550 PerlIO_printf(Perl_debug_log,
2551 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2552 (int) HeKLEN(entry), HeKEY(entry));
2553 bad = 1;
2554 }
2555 } else if (HeKWASUTF8(entry)) {
2556 withflags++;
2557 }
2558 }
2559 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2560 if (HvUSEDKEYS(hv) != real) {
2561 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2562 (int) real, (int) HvUSEDKEYS(hv));
2563 bad = 1;
2564 }
5d88ecd7 2565 if (HvPLACEHOLDERS_get(hv) != placeholders) {
ecae49c0
NC
2566 PerlIO_printf(Perl_debug_log,
2567 "Count %d placeholder(s), but hash reports %d\n",
5d88ecd7 2568 (int) placeholders, (int) HvPLACEHOLDERS_get(hv));
ecae49c0
NC
2569 bad = 1;
2570 }
2571 }
2572 if (withflags && ! HvHASKFLAGS(hv)) {
2573 PerlIO_printf(Perl_debug_log,
2574 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2575 withflags);
2576 bad = 1;
2577 }
2578 if (bad) {
2579 sv_dump((SV *)hv);
2580 }
bfcb3514
NC
2581 HvRITER_set(hv, riter); /* Restore hash iterator state */
2582 HvEITER_set(hv, eiter);
ecae49c0 2583}
af3babe4
NC
2584
2585/*
2586 * Local variables:
2587 * c-indentation-style: bsd
2588 * c-basic-offset: 4
2589 * indent-tabs-mode: t
2590 * End:
2591 *
37442d52
RGS
2592 * ex: set ts=8 sts=4 sw=4 noet:
2593 */