This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
"Space Is a Province of Brazil"
[perl5.git] / hv.c
CommitLineData
a0d0e21e 1/* hv.c
79072805 2 *
4bb101f2
JH
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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
17*/
18
79072805 19#include "EXTERN.h"
864dbfa3 20#define PERL_IN_HV_C
3d78eb94 21#define PERL_HASH_INTERNAL_ACCESS
79072805
LW
22#include "perl.h"
23
d8012aaf 24#define HV_MAX_LENGTH_BEFORE_SPLIT 14
fdcd69b6 25
76e3520e 26STATIC HE*
cea2e8a9 27S_new_he(pTHX)
4633a7c4
LW
28{
29 HE* he;
333f433b
DG
30 LOCK_SV_MUTEX;
31 if (!PL_he_root)
8aacddc1 32 more_he();
333f433b
DG
33 he = PL_he_root;
34 PL_he_root = HeNEXT(he);
35 UNLOCK_SV_MUTEX;
36 return he;
4633a7c4
LW
37}
38
76e3520e 39STATIC void
cea2e8a9 40S_del_he(pTHX_ HE *p)
4633a7c4 41{
333f433b 42 LOCK_SV_MUTEX;
3280af22
NIS
43 HeNEXT(p) = (HE*)PL_he_root;
44 PL_he_root = p;
333f433b 45 UNLOCK_SV_MUTEX;
4633a7c4
LW
46}
47
333f433b 48STATIC void
cea2e8a9 49S_more_he(pTHX)
4633a7c4
LW
50{
51 register HE* he;
52 register HE* heend;
612f20c3
GS
53 XPV *ptr;
54 New(54, ptr, 1008/sizeof(XPV), XPV);
55 ptr->xpv_pv = (char*)PL_he_arenaroot;
56 PL_he_arenaroot = ptr;
57
58 he = (HE*)ptr;
4633a7c4 59 heend = &he[1008 / sizeof(HE) - 1];
612f20c3 60 PL_he_root = ++he;
4633a7c4 61 while (he < heend) {
8aacddc1
NIS
62 HeNEXT(he) = (HE*)(he + 1);
63 he++;
4633a7c4 64 }
fde52b5c 65 HeNEXT(he) = 0;
4633a7c4
LW
66}
67
d33b2eba
GS
68#ifdef PURIFY
69
70#define new_HE() (HE*)safemalloc(sizeof(HE))
71#define del_HE(p) safefree((char*)p)
72
73#else
74
75#define new_HE() new_he()
76#define del_HE(p) del_he(p)
77
78#endif
79
76e3520e 80STATIC HEK *
19692e8d 81S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
bbce6d69
PP
82{
83 char *k;
84 register HEK *hek;
1c846c1f 85
e05949c7 86 New(54, k, HEK_BASESIZE + len + 2, char);
bbce6d69 87 hek = (HEK*)k;
ff68c719 88 Copy(str, HEK_KEY(hek), len, char);
e05949c7 89 HEK_KEY(hek)[len] = 0;
ff68c719
PP
90 HEK_LEN(hek) = len;
91 HEK_HASH(hek) = hash;
19692e8d 92 HEK_FLAGS(hek) = (unsigned char)flags;
bbce6d69
PP
93 return hek;
94}
95
dd28f7bb
DM
96/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
97 * for tied hashes */
98
99void
100Perl_free_tied_hv_pool(pTHX)
101{
102 HE *ohe;
103 HE *he = PL_hv_fetch_ent_mh;
104 while (he) {
105 Safefree(HeKEY_hek(he));
106 ohe = he;
107 he = HeNEXT(he);
108 del_HE(ohe);
109 }
bf9cdc68 110 PL_hv_fetch_ent_mh = Nullhe;
dd28f7bb
DM
111}
112
d18c6117
GS
113#if defined(USE_ITHREADS)
114HE *
a8fc9800 115Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
d18c6117
GS
116{
117 HE *ret;
118
119 if (!e)
120 return Nullhe;
7766f137
GS
121 /* look for it in the table first */
122 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
123 if (ret)
124 return ret;
125
126 /* create anew and remember what it is */
d33b2eba 127 ret = new_HE();
7766f137
GS
128 ptr_table_store(PL_ptr_table, e, ret);
129
d2d73c3e 130 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
dd28f7bb
DM
131 if (HeKLEN(e) == HEf_SVKEY) {
132 char *k;
133 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
134 HeKEY_hek(ret) = (HEK*)k;
d2d73c3e 135 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
dd28f7bb 136 }
d18c6117 137 else if (shared)
19692e8d
NC
138 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
139 HeKFLAGS(e));
d18c6117 140 else
19692e8d
NC
141 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
142 HeKFLAGS(e));
d2d73c3e 143 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
d18c6117
GS
144 return ret;
145}
146#endif /* USE_ITHREADS */
147
1b1f1335 148static void
2393f1b9
JH
149S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
150 const char *msg)
1b1f1335 151{
2393f1b9 152 SV *sv = sv_newmortal(), *esv = sv_newmortal();
19692e8d 153 if (!(flags & HVhek_FREEKEY)) {
1b1f1335
NIS
154 sv_setpvn(sv, key, klen);
155 }
156 else {
157 /* Need to free saved eventually assign to mortal SV */
34c3c4e3 158 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
1b1f1335
NIS
159 sv_usepvn(sv, (char *) key, klen);
160 }
19692e8d 161 if (flags & HVhek_UTF8) {
1b1f1335
NIS
162 SvUTF8_on(sv);
163 }
2393f1b9
JH
164 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
165 Perl_croak(aTHX_ SvPVX(esv), sv);
1b1f1335
NIS
166}
167
fde52b5c
PP
168/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
169 * contains an SV* */
170
954c1994
GS
171/*
172=for apidoc hv_fetch
173
174Returns the SV which corresponds to the specified key in the hash. The
175C<klen> is the length of the key. If C<lval> is set then the fetch will be
176part of a store. Check that the return value is non-null before
d1be9408 177dereferencing it to an C<SV*>.
954c1994 178
96f1132b 179See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
180information on how to use this function on tied hashes.
181
182=cut
183*/
184
7f66fda2
NC
185#define HV_FETCH_ISSTORE 0x01
186#define HV_FETCH_ISEXISTS 0x02
187#define HV_FETCH_LVALUE 0x04
188#define HV_FETCH_JUST_SV 0x08
19692e8d 189
79072805 190SV**
c1fe5510 191Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
79072805 192{
c1fe5510
NC
193 HE *hek;
194 STRLEN klen;
195 int flags;
196
197 if (klen_i32 < 0) {
198 klen = -klen_i32;
199 flags = HVhek_UTF8;
200 } else {
201 klen = klen_i32;
202 flags = 0;
203 }
204 hek = hv_fetch_common (hv, NULL, key, klen, flags,
b2c64049
NC
205 HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
206 Nullsv, 0);
113738bb 207 return hek ? &HeVAL(hek) : NULL;
79072805
LW
208}
209
d1be9408 210/* returns an HE * structure with the all fields set */
fde52b5c 211/* note that hent_val will be a mortal sv for MAGICAL hashes */
954c1994
GS
212/*
213=for apidoc hv_fetch_ent
214
215Returns the hash entry which corresponds to the specified key in the hash.
216C<hash> must be a valid precomputed hash number for the given C<key>, or 0
217if you want the function to compute it. IF C<lval> is set then the fetch
218will be part of a store. Make sure the return value is non-null before
219accessing it. The return value when C<tb> is a tied hash is a pointer to a
220static location, so be sure to make a copy of the structure if you need to
1c846c1f 221store it somewhere.
954c1994 222
96f1132b 223See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
224information on how to use this function on tied hashes.
225
226=cut
227*/
228
fde52b5c 229HE *
864dbfa3 230Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
fde52b5c 231{
7f66fda2 232 return hv_fetch_common(hv, keysv, NULL, 0, 0,
b2c64049 233 (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
113738bb
NC
234}
235
236HE *
c1fe5510 237S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
b2c64049 238 int flags, int action, SV *val, register U32 hash)
113738bb 239{
b2c64049
NC
240 XPVHV* xhv;
241 U32 n_links;
242 HE *entry;
243 HE **oentry;
fde52b5c 244 SV *sv;
da58a35d 245 bool is_utf8;
113738bb 246 int masked_flags;
fde52b5c
PP
247
248 if (!hv)
249 return 0;
250
113738bb
NC
251 if (keysv) {
252 key = SvPV(keysv, klen);
c1fe5510 253 flags = 0;
113738bb
NC
254 is_utf8 = (SvUTF8(keysv) != 0);
255 } else {
c1fe5510 256 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
113738bb 257 }
113738bb 258
b2c64049 259 xhv = (XPVHV*)SvANY(hv);
7f66fda2
NC
260 if (SvMAGICAL(hv)) {
261 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
262 {
263 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
264 sv = sv_newmortal();
113738bb 265
7f66fda2
NC
266 /* XXX should be able to skimp on the HE/HEK here when
267 HV_FETCH_JUST_SV is true. */
113738bb 268
7f66fda2
NC
269 if (!keysv) {
270 keysv = newSVpvn(key, klen);
271 if (is_utf8) {
272 SvUTF8_on(keysv);
273 }
274 } else {
275 keysv = newSVsv(keysv);
113738bb 276 }
7f66fda2
NC
277 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
278
279 /* grab a fake HE/HEK pair from the pool or make a new one */
280 entry = PL_hv_fetch_ent_mh;
281 if (entry)
282 PL_hv_fetch_ent_mh = HeNEXT(entry);
283 else {
284 char *k;
285 entry = new_HE();
286 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
287 HeKEY_hek(entry) = (HEK*)k;
288 }
289 HeNEXT(entry) = Nullhe;
290 HeSVKEY_set(entry, keysv);
291 HeVAL(entry) = sv;
292 sv_upgrade(sv, SVt_PVLV);
293 LvTYPE(sv) = 'T';
294 /* so we can free entry when freeing sv */
295 LvTARG(sv) = (SV*)entry;
296
297 /* XXX remove at some point? */
298 if (flags & HVhek_FREEKEY)
299 Safefree(key);
300
301 return entry;
113738bb 302 }
7f66fda2
NC
303#ifdef ENV_IS_CASELESS
304 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
305 U32 i;
306 for (i = 0; i < klen; ++i)
307 if (isLOWER(key[i])) {
b2c64049
NC
308 const char *keysave = key;
309 /* Will need to free this, so set FREEKEY flag
310 on call to hv_fetch_common. */
311 key = savepvn(key,klen);
312 key = (const char*)strupr((char*)key);
7f66fda2 313
7f66fda2 314 if (flags & HVhek_FREEKEY)
b2c64049
NC
315 Safefree(keysave);
316
317 /* This isn't strictly the same as the old hv_fetch
318 magic, which made a call to hv_fetch, followed
319 by a call to hv_store if that failed and lvalue
320 was true.
321 Which I believe could have been done by simply
322 passing the lvalue through to the first hv_fetch.
323 So I will do that here. */
324 return hv_fetch_common(hv, Nullsv, key, klen,
325 HVhek_FREEKEY,
326 action, Nullsv, 0);
7f66fda2 327 }
902173a3 328 }
7f66fda2
NC
329#endif
330 } /* ISFETCH */
331 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
332 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
333 SV* svret;
b2c64049
NC
334 /* I don't understand why hv_exists_ent has svret and sv,
335 whereas hv_exists only had one. */
336 svret = sv_newmortal();
337 sv = sv_newmortal();
7f66fda2
NC
338
339 if (keysv || is_utf8) {
340 if (!keysv) {
341 keysv = newSVpvn(key, klen);
342 SvUTF8_on(keysv);
343 } else {
344 keysv = newSVsv(keysv);
345 }
b2c64049
NC
346 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
347 } else {
348 mg_copy((SV*)hv, sv, key, klen);
7f66fda2 349 }
b2c64049
NC
350 if (flags & HVhek_FREEKEY)
351 Safefree(key);
7f66fda2
NC
352 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
353 /* This cast somewhat evil, but I'm merely using NULL/
354 not NULL to return the boolean exists.
355 And I know hv is not NULL. */
356 return SvTRUE(svret) ? (HE *)hv : NULL;
e7152ba2 357 }
7f66fda2
NC
358#ifdef ENV_IS_CASELESS
359 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
360 /* XXX This code isn't UTF8 clean. */
b2c64049
NC
361 const char *keysave = key;
362 /* Will need to free this, so set FREEKEY flag. */
363 key = savepvn(key,klen);
364 key = (const char*)strupr((char*)key);
7f66fda2
NC
365 is_utf8 = 0;
366 hash = 0;
b2c64049
NC
367
368 if (flags & HVhek_FREEKEY) {
369 Safefree(keysave);
370 }
371 flags |= HVhek_FREEKEY;
7f66fda2 372 }
902173a3 373#endif
7f66fda2 374 } /* ISEXISTS */
b2c64049
NC
375 else if (action & HV_FETCH_ISSTORE) {
376 bool needs_copy;
377 bool needs_store;
378 hv_magic_check (hv, &needs_copy, &needs_store);
379 if (needs_copy) {
380 bool save_taint = PL_tainted;
381 if (keysv || is_utf8) {
382 if (!keysv) {
383 keysv = newSVpvn(key, klen);
384 SvUTF8_on(keysv);
385 }
386 if (PL_tainting)
387 PL_tainted = SvTAINTED(keysv);
388 keysv = sv_2mortal(newSVsv(keysv));
389 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
390 } else {
391 mg_copy((SV*)hv, val, key, klen);
392 }
393
394 TAINT_IF(save_taint);
395 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
396 if (flags & HVhek_FREEKEY)
397 Safefree(key);
398 return Nullhe;
399 }
400#ifdef ENV_IS_CASELESS
401 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
402 /* XXX This code isn't UTF8 clean. */
403 const char *keysave = key;
404 /* Will need to free this, so set FREEKEY flag. */
405 key = savepvn(key,klen);
406 key = (const char*)strupr((char*)key);
407 is_utf8 = 0;
408 hash = 0;
409
410 if (flags & HVhek_FREEKEY) {
411 Safefree(keysave);
412 }
413 flags |= HVhek_FREEKEY;
414 }
415#endif
416 }
417 } /* ISSTORE */
7f66fda2 418 } /* SvMAGICAL */
fde52b5c 419
cbec9347 420 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
b2c64049 421 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
fde52b5c 422#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
8aacddc1 423 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
fde52b5c 424#endif
8aacddc1 425 )
cbec9347
JH
426 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
427 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
428 char);
7f66fda2
NC
429#ifdef DYNAMIC_ENV_FETCH
430 else if (action & HV_FETCH_ISEXISTS) {
431 /* for an %ENV exists, if we do an insert it's by a recursive
432 store call, so avoid creating HvARRAY(hv) right now. */
433 }
434#endif
113738bb
NC
435 else {
436 /* XXX remove at some point? */
437 if (flags & HVhek_FREEKEY)
438 Safefree(key);
439
fde52b5c 440 return 0;
113738bb 441 }
fde52b5c
PP
442 }
443
19692e8d 444 if (is_utf8) {
7f66fda2 445 const char *keysave = key;
f9a63242 446 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
19692e8d 447 if (is_utf8)
c1fe5510
NC
448 flags |= HVhek_UTF8;
449 else
450 flags &= ~HVhek_UTF8;
7f66fda2
NC
451 if (key != keysave) {
452 if (flags & HVhek_FREEKEY)
453 Safefree(keysave);
19692e8d 454 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
7f66fda2 455 }
19692e8d 456 }
f9a63242 457
4b5190b5
NC
458 if (HvREHASH(hv)) {
459 PERL_HASH_INTERNAL(hash, key, klen);
b2c64049
NC
460 /* We don't have a pointer to the hv, so we have to replicate the
461 flag into every HEK, so that hv_iterkeysv can see it. */
462 /* And yes, you do need this even though you are not "storing" because
fdcd69b6
NC
463 you can flip the flags below if doing an lval lookup. (And that
464 was put in to give the semantics Andreas was expecting.) */
465 flags |= HVhek_REHASH;
4b5190b5 466 } else if (!hash) {
113738bb 467 if (keysv && (SvIsCOW_shared_hash(keysv))) {
46187eeb
NC
468 hash = SvUVX(keysv);
469 } else {
470 PERL_HASH(hash, key, klen);
471 }
472 }
effa1e2d 473
113738bb 474 masked_flags = (flags & HVhek_MASK);
b2c64049 475 n_links = 0;
113738bb 476
7f66fda2
NC
477#ifdef DYNAMIC_ENV_FETCH
478 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
479 else
480#endif
b2c64049
NC
481 {
482 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
483 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
484 entry = *oentry;
485 }
486 for (; entry; ++n_links, entry = HeNEXT(entry)) {
fde52b5c
PP
487 if (HeHASH(entry) != hash) /* strings can't be equal */
488 continue;
eb160463 489 if (HeKLEN(entry) != (I32)klen)
fde52b5c 490 continue;
1c846c1f 491 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 492 continue;
113738bb 493 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 494 continue;
b2c64049
NC
495
496 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
497 if (HeKFLAGS(entry) != masked_flags) {
498 /* We match if HVhek_UTF8 bit in our flags and hash key's
499 match. But if entry was set previously with HVhek_WASUTF8
500 and key now doesn't (or vice versa) then we should change
501 the key's flag, as this is assignment. */
502 if (HvSHAREKEYS(hv)) {
503 /* Need to swap the key we have for a key with the flags we
504 need. As keys are shared we can't just write to the
505 flag, so we share the new one, unshare the old one. */
506 HEK *new_hek = share_hek_flags(key, klen, hash,
507 masked_flags);
508 unshare_hek (HeKEY_hek(entry));
509 HeKEY_hek(entry) = new_hek;
510 }
511 else
512 HeKFLAGS(entry) = masked_flags;
513 if (masked_flags & HVhek_ENABLEHVKFLAGS)
514 HvHASKFLAGS_on(hv);
515 }
516 if (HeVAL(entry) == &PL_sv_placeholder) {
517 /* yes, can store into placeholder slot */
518 if (action & HV_FETCH_LVALUE) {
519 if (SvMAGICAL(hv)) {
520 /* This preserves behaviour with the old hv_fetch
521 implementation which at this point would bail out
522 with a break; (at "if we find a placeholder, we
523 pretend we haven't found anything")
524
525 That break mean that if a placeholder were found, it
526 caused a call into hv_store, which in turn would
527 check magic, and if there is no magic end up pretty
528 much back at this point (in hv_store's code). */
529 break;
530 }
531 /* LVAL fetch which actaully needs a store. */
532 val = NEWSV(61,0);
533 xhv->xhv_placeholders--;
534 } else {
535 /* store */
536 if (val != &PL_sv_placeholder)
537 xhv->xhv_placeholders--;
538 }
539 HeVAL(entry) = val;
540 } else if (action & HV_FETCH_ISSTORE) {
541 SvREFCNT_dec(HeVAL(entry));
542 HeVAL(entry) = val;
543 }
544 } else if (HeVAL(entry) == &PL_sv_placeholder) {
545 /* if we find a placeholder, we pretend we haven't found
546 anything */
8aacddc1 547 break;
b2c64049 548 }
113738bb
NC
549 if (flags & HVhek_FREEKEY)
550 Safefree(key);
fde52b5c
PP
551 return entry;
552 }
553#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
cbec9347 554 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364
GS
555 unsigned long len;
556 char *env = PerlEnv_ENVgetenv_len(key,&len);
557 if (env) {
558 sv = newSVpvn(env,len);
559 SvTAINTED_on(sv);
b2c64049
NC
560 return hv_fetch_common(hv,keysv,key,keylen,HV_FETCH_ISSTORE,sv,
561 hash);
a6c40364 562 }
fde52b5c
PP
563 }
564#endif
7f66fda2
NC
565
566 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
2393f1b9
JH
567 S_hv_notallowed(aTHX_ flags, key, klen,
568 "access disallowed key '%"SVf"' in"
569 );
1b1f1335 570 }
b2c64049
NC
571 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
572 /* Not doing some form of store, so return failure. */
573 if (flags & HVhek_FREEKEY)
574 Safefree(key);
575 return 0;
576 }
113738bb 577 if (action & HV_FETCH_LVALUE) {
b2c64049
NC
578 val = NEWSV(61,0);
579 if (SvMAGICAL(hv)) {
580 /* At this point the old hv_fetch code would call to hv_store,
581 which in turn might do some tied magic. So we need to make that
582 magic check happen. */
583 /* gonna assign to this, so it better be there */
584 return hv_fetch_common(hv, keysv, key, klen, flags,
585 HV_FETCH_ISSTORE, val, hash);
586 /* XXX Surely that could leak if the fetch-was-store fails?
587 Just like the hv_fetch. */
113738bb
NC
588 }
589 }
590
b2c64049
NC
591 /* Welcome to hv_store... */
592
593 if (!oentry) {
594 /* Not sure if we can get here. I think the only case of oentry being
595 NULL is for %ENV with dynamic env fetch. But that should disappear
596 with magic in the previous code. */
597 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
598 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
599 char);
600 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
601 }
602
603 entry = new_HE();
604 /* share_hek_flags will do the free for us. This might be considered
605 bad API design. */
606 if (HvSHAREKEYS(hv))
607 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
608 else /* gotta do the real thing */
609 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
610 HeVAL(entry) = val;
611 HeNEXT(entry) = *oentry;
612 *oentry = entry;
613
614 if (val == &PL_sv_placeholder)
615 xhv->xhv_placeholders++;
616 if (masked_flags & HVhek_ENABLEHVKFLAGS)
617 HvHASKFLAGS_on(hv);
618
619 xhv->xhv_keys++; /* HvKEYS(hv)++ */
620 if (!n_links) { /* initial entry? */
621 xhv->xhv_fill++; /* HvFILL(hv)++ */
622 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
623 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
624 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
625 splits on a rehashed hash, as we're not going to split it again,
626 and if someone is lucky (evil) enough to get all the keys in one
627 list they could exhaust our memory as we repeatedly double the
628 number of buckets on every entry. Linear search feels a less worse
629 thing to do. */
630 hsplit(hv);
fde52b5c 631 }
b2c64049
NC
632
633 return entry;
fde52b5c
PP
634}
635
864dbfa3 636STATIC void
cea2e8a9 637S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
d0066dc7
OT
638{
639 MAGIC *mg = SvMAGIC(hv);
640 *needs_copy = FALSE;
641 *needs_store = TRUE;
642 while (mg) {
643 if (isUPPER(mg->mg_type)) {
644 *needs_copy = TRUE;
645 switch (mg->mg_type) {
14befaf4
DM
646 case PERL_MAGIC_tied:
647 case PERL_MAGIC_sig:
d0066dc7 648 *needs_store = FALSE;
d0066dc7
OT
649 }
650 }
651 mg = mg->mg_moremagic;
652 }
653}
654
954c1994
GS
655/*
656=for apidoc hv_store
657
658Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
659the length of the key. The C<hash> parameter is the precomputed hash
660value; if it is zero then Perl will compute it. The return value will be
661NULL if the operation failed or if the value did not need to be actually
662stored within the hash (as in the case of tied hashes). Otherwise it can
663be dereferenced to get the original C<SV*>. Note that the caller is
664responsible for suitably incrementing the reference count of C<val> before
4f646c4b
NC
665the call, and decrementing it if the function returned NULL. Effectively
666a successful hv_store takes ownership of one reference to C<val>. This is
667usually what you want; a newly created SV has a reference count of one, so
668if all your code does is create SVs then store them in a hash, hv_store
669will own the only reference to the new SV, and your code doesn't need to do
670anything further to tidy up. hv_store is not implemented as a call to
671hv_store_ent, and does not create a temporary SV for the key, so if your
672key data is not already in SV form then use hv_store in preference to
673hv_store_ent.
954c1994 674
96f1132b 675See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
676information on how to use this function on tied hashes.
677
678=cut
679*/
680
79072805 681SV**
a8adfdb3 682Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
19692e8d 683{
a8adfdb3
NC
684 HE *hek;
685 STRLEN klen;
686 int flags;
687
688 if (klen_i32 < 0) {
689 klen = -klen_i32;
690 flags = HVhek_UTF8;
691 } else {
692 klen = klen_i32;
693 flags = 0;
694 }
b2c64049
NC
695 hek = hv_fetch_common (hv, NULL, key, klen, flags,
696 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0);
570c4e91 697 return hek ? &HeVAL(hek) : NULL;
19692e8d
NC
698}
699
700SV**
e16e2ff8 701Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
19692e8d 702 register U32 hash, int flags)
79072805 703{
b2c64049
NC
704 HE *hek = hv_fetch_common (hv, NULL, key, klen, flags,
705 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
570c4e91 706 return hek ? &HeVAL(hek) : NULL;
fde52b5c
PP
707}
708
954c1994
GS
709/*
710=for apidoc hv_store_ent
711
712Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
713parameter is the precomputed hash value; if it is zero then Perl will
714compute it. The return value is the new hash entry so created. It will be
715NULL if the operation failed or if the value did not need to be actually
716stored within the hash (as in the case of tied hashes). Otherwise the
87324b0f 717contents of the return value can be accessed using the C<He?> macros
954c1994
GS
718described here. Note that the caller is responsible for suitably
719incrementing the reference count of C<val> before the call, and
4f646c4b
NC
720decrementing it if the function returned NULL. Effectively a successful
721hv_store_ent takes ownership of one reference to C<val>. This is
722usually what you want; a newly created SV has a reference count of one, so
723if all your code does is create SVs then store them in a hash, hv_store
724will own the only reference to the new SV, and your code doesn't need to do
725anything further to tidy up. Note that hv_store_ent only reads the C<key>;
726unlike C<val> it does not take ownership of it, so maintaining the correct
727reference count on C<key> is entirely the caller's responsibility. hv_store
728is not implemented as a call to hv_store_ent, and does not create a temporary
729SV for the key, so if your key data is not already in SV form then use
730hv_store in preference to hv_store_ent.
954c1994 731
96f1132b 732See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
733information on how to use this function on tied hashes.
734
735=cut
736*/
737
fde52b5c 738HE *
19692e8d 739Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
fde52b5c 740{
b2c64049 741 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
79072805
LW
742}
743
954c1994
GS
744/*
745=for apidoc hv_delete
746
747Deletes a key/value pair in the hash. The value SV is removed from the
1c846c1f 748hash and returned to the caller. The C<klen> is the length of the key.
954c1994
GS
749The C<flags> value will normally be zero; if set to G_DISCARD then NULL
750will be returned.
751
752=cut
753*/
754
79072805 755SV *
cd6d36ac 756Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
79072805 757{
cd6d36ac
NC
758 STRLEN klen;
759 int k_flags = 0;
760
761 if (klen_i32 < 0) {
762 klen = -klen_i32;
763 k_flags |= HVhek_UTF8;
764 } else {
765 klen = klen_i32;
766 }
767 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
fde52b5c
PP
768}
769
954c1994
GS
770/*
771=for apidoc hv_delete_ent
772
773Deletes a key/value pair in the hash. The value SV is removed from the
774hash and returned to the caller. The C<flags> value will normally be zero;
775if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
776precomputed hash value, or 0 to ask for it to be computed.
777
778=cut
779*/
780
fde52b5c 781SV *
864dbfa3 782Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
fde52b5c 783{
cd6d36ac 784 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
f1317c8d
NC
785}
786
787SV *
cd6d36ac
NC
788S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
789 int k_flags, I32 d_flags, U32 hash)
f1317c8d 790{
cbec9347 791 register XPVHV* xhv;
fde52b5c 792 register I32 i;
fde52b5c
PP
793 register HE *entry;
794 register HE **oentry;
795 SV *sv;
da58a35d 796 bool is_utf8;
7a9669ca 797 int masked_flags;
1c846c1f 798
fde52b5c
PP
799 if (!hv)
800 return Nullsv;
f1317c8d
NC
801
802 if (keysv) {
803 key = SvPV(keysv, klen);
cd6d36ac 804 k_flags = 0;
f1317c8d
NC
805 is_utf8 = (SvUTF8(keysv) != 0);
806 } else {
cd6d36ac 807 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
f1317c8d 808 }
f1317c8d 809
fde52b5c 810 if (SvRMAGICAL(hv)) {
0a0bb7c7
OT
811 bool needs_copy;
812 bool needs_store;
813 hv_magic_check (hv, &needs_copy, &needs_store);
814
f1317c8d 815 if (needs_copy) {
7a9669ca
NC
816 entry = hv_fetch_common(hv, keysv, key, klen,
817 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
b2c64049 818 Nullsv, hash);
7a9669ca 819 sv = entry ? HeVAL(entry) : NULL;
f1317c8d
NC
820 if (sv) {
821 if (SvMAGICAL(sv)) {
822 mg_clear(sv);
823 }
824 if (!needs_store) {
825 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
826 /* No longer an element */
827 sv_unmagic(sv, PERL_MAGIC_tiedelem);
828 return sv;
829 }
830 return Nullsv; /* element cannot be deleted */
831 }
0a0bb7c7 832 }
902173a3 833#ifdef ENV_IS_CASELESS
14befaf4 834 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
f1317c8d 835 /* XXX This code isn't UTF8 clean. */
79cb57f6 836 keysv = sv_2mortal(newSVpvn(key,klen));
7f66fda2
NC
837 key = strupr(SvPVX(keysv));
838
839 if (k_flags & HVhek_FREEKEY) {
840 Safefree(keysave);
841 }
842
f1317c8d 843 is_utf8 = 0;
cd6d36ac 844 k_flags = 0;
1c846c1f 845 hash = 0;
2fd1c6b8 846 }
902173a3 847#endif
2fd1c6b8 848 }
fde52b5c 849 }
cbec9347
JH
850 xhv = (XPVHV*)SvANY(hv);
851 if (!xhv->xhv_array /* !HvARRAY(hv) */)
fde52b5c
PP
852 return Nullsv;
853
19692e8d 854 if (is_utf8) {
7f66fda2
NC
855 const char *keysave = key;
856 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
cd6d36ac 857
19692e8d 858 if (is_utf8)
cd6d36ac
NC
859 k_flags |= HVhek_UTF8;
860 else
861 k_flags &= ~HVhek_UTF8;
7f66fda2
NC
862 if (key != keysave) {
863 if (k_flags & HVhek_FREEKEY) {
864 /* This shouldn't happen if our caller does what we expect,
865 but strictly the API allows it. */
866 Safefree(keysave);
867 }
868 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
869 }
cd6d36ac 870 HvHASKFLAGS_on((SV*)hv);
19692e8d 871 }
f9a63242 872
4b5190b5
NC
873 if (HvREHASH(hv)) {
874 PERL_HASH_INTERNAL(hash, key, klen);
875 } else if (!hash) {
7a9669ca
NC
876 if (keysv && (SvIsCOW_shared_hash(keysv))) {
877 hash = SvUVX(keysv);
878 } else {
879 PERL_HASH(hash, key, klen);
880 }
5afd6d42 881 PERL_HASH(hash, key, klen);
4b5190b5 882 }
fde52b5c 883
7a9669ca
NC
884 masked_flags = (k_flags & HVhek_MASK);
885
cbec9347
JH
886 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
887 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
888 entry = *oentry;
889 i = 1;
890 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
891 if (HeHASH(entry) != hash) /* strings can't be equal */
892 continue;
eb160463 893 if (HeKLEN(entry) != (I32)klen)
fde52b5c 894 continue;
1c846c1f 895 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 896 continue;
7a9669ca 897 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 898 continue;
19692e8d
NC
899 if (k_flags & HVhek_FREEKEY)
900 Safefree(key);
8aacddc1
NIS
901
902 /* if placeholder is here, it's already been deleted.... */
7996736c 903 if (HeVAL(entry) == &PL_sv_placeholder)
8aacddc1
NIS
904 {
905 if (SvREADONLY(hv))
906 return Nullsv; /* if still SvREADONLY, leave it deleted. */
03fed38d
MB
907
908 /* okay, really delete the placeholder. */
909 *oentry = HeNEXT(entry);
910 if (i && !*oentry)
911 xhv->xhv_fill--; /* HvFILL(hv)-- */
912 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
913 HvLAZYDEL_on(hv);
914 else
915 hv_free_ent(hv, entry);
916 xhv->xhv_keys--; /* HvKEYS(hv)-- */
574c8022 917 if (xhv->xhv_keys == 0)
19692e8d 918 HvHASKFLAGS_off(hv);
03fed38d
MB
919 xhv->xhv_placeholders--;
920 return Nullsv;
8aacddc1
NIS
921 }
922 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
2393f1b9
JH
923 S_hv_notallowed(aTHX_ k_flags, key, klen,
924 "delete readonly key '%"SVf"' from"
925 );
8aacddc1
NIS
926 }
927
cd6d36ac 928 if (d_flags & G_DISCARD)
fde52b5c 929 sv = Nullsv;
94f7643d 930 else {
79d01fbf 931 sv = sv_2mortal(HeVAL(entry));
7996736c 932 HeVAL(entry) = &PL_sv_placeholder;
94f7643d 933 }
8aacddc1
NIS
934
935 /*
936 * If a restricted hash, rather than really deleting the entry, put
937 * a placeholder there. This marks the key as being "approved", so
938 * we can still access via not-really-existing key without raising
939 * an error.
940 */
941 if (SvREADONLY(hv)) {
7996736c 942 HeVAL(entry) = &PL_sv_placeholder;
8aacddc1
NIS
943 /* We'll be saving this slot, so the number of allocated keys
944 * doesn't go down, but the number placeholders goes up */
945 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
946 } else {
a26e96df
NIS
947 *oentry = HeNEXT(entry);
948 if (i && !*oentry)
949 xhv->xhv_fill--; /* HvFILL(hv)-- */
8aacddc1
NIS
950 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
951 HvLAZYDEL_on(hv);
952 else
953 hv_free_ent(hv, entry);
954 xhv->xhv_keys--; /* HvKEYS(hv)-- */
574c8022 955 if (xhv->xhv_keys == 0)
19692e8d 956 HvHASKFLAGS_off(hv);
8aacddc1 957 }
79072805
LW
958 return sv;
959 }
8aacddc1 960 if (SvREADONLY(hv)) {
2393f1b9
JH
961 S_hv_notallowed(aTHX_ k_flags, key, klen,
962 "delete disallowed key '%"SVf"' from"
963 );
8aacddc1
NIS
964 }
965
19692e8d 966 if (k_flags & HVhek_FREEKEY)
f9a63242 967 Safefree(key);
79072805 968 return Nullsv;
79072805
LW
969}
970
954c1994
GS
971/*
972=for apidoc hv_exists
973
974Returns a boolean indicating whether the specified hash key exists. The
975C<klen> is the length of the key.
976
977=cut
978*/
979
a0d0e21e 980bool
9b7c1c41 981Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
a0d0e21e 982{
9b7c1c41
NC
983 STRLEN klen;
984 int flags;
985
986 if (klen_i32 < 0) {
987 klen = -klen_i32;
988 flags = HVhek_UTF8;
989 } else {
990 klen = klen_i32;
991 flags = 0;
992 }
b2c64049 993 return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
7f66fda2 994 ? TRUE : FALSE;
fde52b5c
PP
995}
996
954c1994
GS
997/*
998=for apidoc hv_exists_ent
999
1000Returns a boolean indicating whether the specified hash key exists. C<hash>
1001can be a valid precomputed hash value, or 0 to ask for it to be
1002computed.
1003
1004=cut
1005*/
1006
fde52b5c 1007bool
864dbfa3 1008Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
fde52b5c 1009{
b2c64049 1010 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
7f66fda2 1011 ? TRUE : FALSE;
71596152
NC
1012}
1013
76e3520e 1014STATIC void
cea2e8a9 1015S_hsplit(pTHX_ HV *hv)
79072805 1016{
cbec9347
JH
1017 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1018 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
79072805
LW
1019 register I32 newsize = oldsize * 2;
1020 register I32 i;
cbec9347 1021 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
72311751
GS
1022 register HE **aep;
1023 register HE **bep;
79072805
LW
1024 register HE *entry;
1025 register HE **oentry;
4b5190b5
NC
1026 int longest_chain = 0;
1027 int was_shared;
79072805 1028
3280af22 1029 PL_nomemok = TRUE;
8d6dde3e 1030#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1031 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1032 if (!a) {
4a33f861 1033 PL_nomemok = FALSE;
422a93e5
GA
1034 return;
1035 }
4633a7c4 1036#else
d18c6117 1037 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1038 if (!a) {
3280af22 1039 PL_nomemok = FALSE;
422a93e5
GA
1040 return;
1041 }
cbec9347 1042 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
fba3b22e 1043 if (oldsize >= 64) {
cbec9347
JH
1044 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1045 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
4633a7c4
LW
1046 }
1047 else
cbec9347 1048 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
4633a7c4
LW
1049#endif
1050
3280af22 1051 PL_nomemok = FALSE;
72311751 1052 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
cbec9347
JH
1053 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1054 xhv->xhv_array = a; /* HvARRAY(hv) = a */
72311751 1055 aep = (HE**)a;
79072805 1056
72311751 1057 for (i=0; i<oldsize; i++,aep++) {
4b5190b5
NC
1058 int left_length = 0;
1059 int right_length = 0;
1060
72311751 1061 if (!*aep) /* non-existent */
79072805 1062 continue;
72311751
GS
1063 bep = aep+oldsize;
1064 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
eb160463 1065 if ((HeHASH(entry) & newsize) != (U32)i) {
fde52b5c 1066 *oentry = HeNEXT(entry);
72311751
GS
1067 HeNEXT(entry) = *bep;
1068 if (!*bep)
cbec9347 1069 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1070 *bep = entry;
4b5190b5 1071 right_length++;
79072805
LW
1072 continue;
1073 }
4b5190b5 1074 else {
fde52b5c 1075 oentry = &HeNEXT(entry);
4b5190b5
NC
1076 left_length++;
1077 }
79072805 1078 }
72311751 1079 if (!*aep) /* everything moved */
cbec9347 1080 xhv->xhv_fill--; /* HvFILL(hv)-- */
4b5190b5
NC
1081 /* I think we don't actually need to keep track of the longest length,
1082 merely flag if anything is too long. But for the moment while
1083 developing this code I'll track it. */
1084 if (left_length > longest_chain)
1085 longest_chain = left_length;
1086 if (right_length > longest_chain)
1087 longest_chain = right_length;
1088 }
1089
1090
1091 /* Pick your policy for "hashing isn't working" here: */
fdcd69b6 1092 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
4b5190b5
NC
1093 || HvREHASH(hv)) {
1094 return;
79072805 1095 }
4b5190b5
NC
1096
1097 if (hv == PL_strtab) {
1098 /* Urg. Someone is doing something nasty to the string table.
1099 Can't win. */
1100 return;
1101 }
1102
1103 /* Awooga. Awooga. Pathological data. */
fdcd69b6 1104 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
4b5190b5
NC
1105 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1106
1107 ++newsize;
1108 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1109 was_shared = HvSHAREKEYS(hv);
1110
1111 xhv->xhv_fill = 0;
1112 HvSHAREKEYS_off(hv);
1113 HvREHASH_on(hv);
1114
1115 aep = (HE **) xhv->xhv_array;
1116
1117 for (i=0; i<newsize; i++,aep++) {
1118 entry = *aep;
1119 while (entry) {
1120 /* We're going to trash this HE's next pointer when we chain it
1121 into the new hash below, so store where we go next. */
1122 HE *next = HeNEXT(entry);
1123 UV hash;
1124
1125 /* Rehash it */
1126 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1127
1128 if (was_shared) {
1129 /* Unshare it. */
1130 HEK *new_hek
1131 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1132 hash, HeKFLAGS(entry));
1133 unshare_hek (HeKEY_hek(entry));
1134 HeKEY_hek(entry) = new_hek;
1135 } else {
1136 /* Not shared, so simply write the new hash in. */
1137 HeHASH(entry) = hash;
1138 }
1139 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1140 HEK_REHASH_on(HeKEY_hek(entry));
1141 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1142
1143 /* Copy oentry to the correct new chain. */
1144 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1145 if (!*bep)
1146 xhv->xhv_fill++; /* HvFILL(hv)++ */
1147 HeNEXT(entry) = *bep;
1148 *bep = entry;
1149
1150 entry = next;
1151 }
1152 }
1153 Safefree (xhv->xhv_array);
1154 xhv->xhv_array = a; /* HvARRAY(hv) = a */
79072805
LW
1155}
1156
72940dca 1157void
864dbfa3 1158Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 1159{
cbec9347
JH
1160 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1161 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
72940dca
PP
1162 register I32 newsize;
1163 register I32 i;
1164 register I32 j;
72311751
GS
1165 register char *a;
1166 register HE **aep;
72940dca
PP
1167 register HE *entry;
1168 register HE **oentry;
1169
1170 newsize = (I32) newmax; /* possible truncation here */
1171 if (newsize != newmax || newmax <= oldsize)
1172 return;
1173 while ((newsize & (1 + ~newsize)) != newsize) {
1174 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1175 }
1176 if (newsize < newmax)
1177 newsize *= 2;
1178 if (newsize < newmax)
1179 return; /* overflow detection */
1180
cbec9347 1181 a = xhv->xhv_array; /* HvARRAY(hv) */
72940dca 1182 if (a) {
3280af22 1183 PL_nomemok = TRUE;
8d6dde3e 1184#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1185 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
8aacddc1 1186 if (!a) {
4a33f861 1187 PL_nomemok = FALSE;
422a93e5
GA
1188 return;
1189 }
72940dca 1190#else
d18c6117 1191 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
8aacddc1 1192 if (!a) {
3280af22 1193 PL_nomemok = FALSE;
422a93e5
GA
1194 return;
1195 }
cbec9347 1196 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
fba3b22e 1197 if (oldsize >= 64) {
cbec9347
JH
1198 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1199 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
72940dca
PP
1200 }
1201 else
cbec9347 1202 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
72940dca 1203#endif
3280af22 1204 PL_nomemok = FALSE;
72311751 1205 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca
PP
1206 }
1207 else {
d18c6117 1208 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
72940dca 1209 }
cbec9347
JH
1210 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1211 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1212 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
72940dca
PP
1213 return;
1214
72311751
GS
1215 aep = (HE**)a;
1216 for (i=0; i<oldsize; i++,aep++) {
1217 if (!*aep) /* non-existent */
72940dca 1218 continue;
72311751 1219 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
72940dca
PP
1220 if ((j = (HeHASH(entry) & newsize)) != i) {
1221 j -= i;
1222 *oentry = HeNEXT(entry);
72311751 1223 if (!(HeNEXT(entry) = aep[j]))
cbec9347 1224 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1225 aep[j] = entry;
72940dca
PP
1226 continue;
1227 }
1228 else
1229 oentry = &HeNEXT(entry);
1230 }
72311751 1231 if (!*aep) /* everything moved */
cbec9347 1232 xhv->xhv_fill--; /* HvFILL(hv)-- */
72940dca
PP
1233 }
1234}
1235
954c1994
GS
1236/*
1237=for apidoc newHV
1238
1239Creates a new HV. The reference count is set to 1.
1240
1241=cut
1242*/
1243
79072805 1244HV *
864dbfa3 1245Perl_newHV(pTHX)
79072805
LW
1246{
1247 register HV *hv;
cbec9347 1248 register XPVHV* xhv;
79072805 1249
a0d0e21e
LW
1250 hv = (HV*)NEWSV(502,0);
1251 sv_upgrade((SV *)hv, SVt_PVHV);
cbec9347 1252 xhv = (XPVHV*)SvANY(hv);
79072805
LW
1253 SvPOK_off(hv);
1254 SvNOK_off(hv);
1c846c1f 1255#ifndef NODEFAULT_SHAREKEYS
fde52b5c 1256 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1c846c1f 1257#endif
4b5190b5 1258
cbec9347
JH
1259 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1260 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1261 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
79072805
LW
1262 (void)hv_iterinit(hv); /* so each() will start off right */
1263 return hv;
1264}
1265
b3ac6de7 1266HV *
864dbfa3 1267Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 1268{
b56ba0bf 1269 HV *hv = newHV();
4beac62f 1270 STRLEN hv_max, hv_fill;
4beac62f
AMS
1271
1272 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1273 return hv;
4beac62f 1274 hv_max = HvMAX(ohv);
b3ac6de7 1275
b56ba0bf
AMS
1276 if (!SvMAGICAL((SV *)ohv)) {
1277 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
eb160463
GS
1278 STRLEN i;
1279 bool shared = !!HvSHAREKEYS(ohv);
b56ba0bf 1280 HE **ents, **oents = (HE **)HvARRAY(ohv);
ff875642
JH
1281 char *a;
1282 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1283 ents = (HE**)a;
b56ba0bf
AMS
1284
1285 /* In each bucket... */
1286 for (i = 0; i <= hv_max; i++) {
1287 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1288
1289 if (!oent) {
1290 ents[i] = NULL;
1291 continue;
1292 }
1293
1294 /* Copy the linked list of entries. */
1295 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1296 U32 hash = HeHASH(oent);
1297 char *key = HeKEY(oent);
19692e8d
NC
1298 STRLEN len = HeKLEN(oent);
1299 int flags = HeKFLAGS(oent);
b56ba0bf
AMS
1300
1301 ent = new_HE();
45dea987 1302 HeVAL(ent) = newSVsv(HeVAL(oent));
19692e8d
NC
1303 HeKEY_hek(ent)
1304 = shared ? share_hek_flags(key, len, hash, flags)
1305 : save_hek_flags(key, len, hash, flags);
b56ba0bf
AMS
1306 if (prev)
1307 HeNEXT(prev) = ent;
1308 else
1309 ents[i] = ent;
1310 prev = ent;
1311 HeNEXT(ent) = NULL;
1312 }
1313 }
1314
1315 HvMAX(hv) = hv_max;
1316 HvFILL(hv) = hv_fill;
8aacddc1 1317 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
b56ba0bf 1318 HvARRAY(hv) = ents;
1c846c1f 1319 }
b56ba0bf
AMS
1320 else {
1321 /* Iterate over ohv, copying keys and values one at a time. */
b3ac6de7 1322 HE *entry;
b56ba0bf
AMS
1323 I32 riter = HvRITER(ohv);
1324 HE *eiter = HvEITER(ohv);
1325
1326 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1327 while (hv_max && hv_max + 1 >= hv_fill * 2)
1328 hv_max = hv_max / 2;
1329 HvMAX(hv) = hv_max;
1330
4a76a316 1331 hv_iterinit(ohv);
e16e2ff8 1332 while ((entry = hv_iternext_flags(ohv, 0))) {
19692e8d
NC
1333 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1334 newSVsv(HeVAL(entry)), HeHASH(entry),
1335 HeKFLAGS(entry));
b3ac6de7 1336 }
b56ba0bf
AMS
1337 HvRITER(ohv) = riter;
1338 HvEITER(ohv) = eiter;
b3ac6de7 1339 }
1c846c1f 1340
b3ac6de7
IZ
1341 return hv;
1342}
1343
79072805 1344void
864dbfa3 1345Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 1346{
16bdeea2
GS
1347 SV *val;
1348
68dc0745 1349 if (!entry)
79072805 1350 return;
16bdeea2 1351 val = HeVAL(entry);
257c9e5b 1352 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
3280af22 1353 PL_sub_generation++; /* may be deletion of method from stash */
16bdeea2 1354 SvREFCNT_dec(val);
68dc0745
PP
1355 if (HeKLEN(entry) == HEf_SVKEY) {
1356 SvREFCNT_dec(HeKEY_sv(entry));
8aacddc1 1357 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1358 }
1359 else if (HvSHAREKEYS(hv))
68dc0745 1360 unshare_hek(HeKEY_hek(entry));
fde52b5c 1361 else
68dc0745 1362 Safefree(HeKEY_hek(entry));
d33b2eba 1363 del_HE(entry);
79072805
LW
1364}
1365
1366void
864dbfa3 1367Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 1368{
68dc0745 1369 if (!entry)
79072805 1370 return;
68dc0745 1371 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
3280af22 1372 PL_sub_generation++; /* may be deletion of method from stash */
68dc0745
PP
1373 sv_2mortal(HeVAL(entry)); /* free between statements */
1374 if (HeKLEN(entry) == HEf_SVKEY) {
1375 sv_2mortal(HeKEY_sv(entry));
1376 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1377 }
1378 else if (HvSHAREKEYS(hv))
68dc0745 1379 unshare_hek(HeKEY_hek(entry));
fde52b5c 1380 else
68dc0745 1381 Safefree(HeKEY_hek(entry));
d33b2eba 1382 del_HE(entry);
79072805
LW
1383}
1384
954c1994
GS
1385/*
1386=for apidoc hv_clear
1387
1388Clears a hash, making it empty.
1389
1390=cut
1391*/
1392
79072805 1393void
864dbfa3 1394Perl_hv_clear(pTHX_ HV *hv)
79072805 1395{
cbec9347 1396 register XPVHV* xhv;
79072805
LW
1397 if (!hv)
1398 return;
49293501 1399
ecae49c0
NC
1400 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1401
34c3c4e3
DM
1402 xhv = (XPVHV*)SvANY(hv);
1403
5f099cb0 1404 if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
34c3c4e3 1405 /* restricted hash: convert all keys to placeholders */
3a676441
JH
1406 I32 i;
1407 HE* entry;
1408 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1409 entry = ((HE**)xhv->xhv_array)[i];
1410 for (; entry; entry = HeNEXT(entry)) {
1411 /* not already placeholder */
7996736c 1412 if (HeVAL(entry) != &PL_sv_placeholder) {
3a676441
JH
1413 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1414 SV* keysv = hv_iterkeysv(entry);
1415 Perl_croak(aTHX_
1416 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1417 keysv);
1418 }
1419 SvREFCNT_dec(HeVAL(entry));
7996736c 1420 HeVAL(entry) = &PL_sv_placeholder;
3a676441
JH
1421 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1422 }
34c3c4e3
DM
1423 }
1424 }
1425 return;
49293501
MS
1426 }
1427
463ee0b2 1428 hfreeentries(hv);
8aacddc1 1429 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
cbec9347
JH
1430 if (xhv->xhv_array /* HvARRAY(hv) */)
1431 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1432 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
a0d0e21e
LW
1433
1434 if (SvRMAGICAL(hv))
1c846c1f 1435 mg_clear((SV*)hv);
574c8022 1436
19692e8d 1437 HvHASKFLAGS_off(hv);
bb443f97 1438 HvREHASH_off(hv);
79072805
LW
1439}
1440
3540d4ce
AB
1441/*
1442=for apidoc hv_clear_placeholders
1443
1444Clears any placeholders from a hash. If a restricted hash has any of its keys
1445marked as readonly and the key is subsequently deleted, the key is not actually
1446deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1447it so it will be ignored by future operations such as iterating over the hash,
1448but will still allow the hash to have a value reaasigned to the key at some
1449future point. This function clears any such placeholder keys from the hash.
1450See Hash::Util::lock_keys() for an example of its use.
1451
1452=cut
1453*/
1454
1455void
1456Perl_hv_clear_placeholders(pTHX_ HV *hv)
1457{
1458 I32 items;
1459 items = (I32)HvPLACEHOLDERS(hv);
1460 if (items) {
1461 HE *entry;
1462 I32 riter = HvRITER(hv);
1463 HE *eiter = HvEITER(hv);
1464 hv_iterinit(hv);
1465 /* This may look suboptimal with the items *after* the iternext, but
1466 it's quite deliberate. We only get here with items==0 if we've
1467 just deleted the last placeholder in the hash. If we've just done
1468 that then it means that the hash is in lazy delete mode, and the
1469 HE is now only referenced in our iterator. If we just quit the loop
1470 and discarded our iterator then the HE leaks. So we do the && the
1471 other way to ensure iternext is called just one more time, which
1472 has the side effect of triggering the lazy delete. */
1473 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1474 && items) {
1475 SV *val = hv_iterval(hv, entry);
1476
1477 if (val == &PL_sv_placeholder) {
1478
1479 /* It seems that I have to go back in the front of the hash
1480 API to delete a hash, even though I have a HE structure
1481 pointing to the very entry I want to delete, and could hold
1482 onto the previous HE that points to it. And it's easier to
1483 go in with SVs as I can then specify the precomputed hash,
1484 and don't have fun and games with utf8 keys. */
1485 SV *key = hv_iterkeysv(entry);
1486
1487 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
1488 items--;
1489 }
1490 }
1491 HvRITER(hv) = riter;
1492 HvEITER(hv) = eiter;
1493 }
1494}
1495
76e3520e 1496STATIC void
cea2e8a9 1497S_hfreeentries(pTHX_ HV *hv)
79072805 1498{
a0d0e21e 1499 register HE **array;
68dc0745
PP
1500 register HE *entry;
1501 register HE *oentry = Null(HE*);
a0d0e21e
LW
1502 I32 riter;
1503 I32 max;
79072805
LW
1504
1505 if (!hv)
1506 return;
a0d0e21e 1507 if (!HvARRAY(hv))
79072805 1508 return;
a0d0e21e
LW
1509
1510 riter = 0;
1511 max = HvMAX(hv);
1512 array = HvARRAY(hv);
2f86008e
DM
1513 /* make everyone else think the array is empty, so that the destructors
1514 * called for freed entries can't recusively mess with us */
1515 HvARRAY(hv) = Null(HE**);
1516 HvFILL(hv) = 0;
1517 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1518
68dc0745 1519 entry = array[0];
a0d0e21e 1520 for (;;) {
68dc0745
PP
1521 if (entry) {
1522 oentry = entry;
1523 entry = HeNEXT(entry);
1524 hv_free_ent(hv, oentry);
a0d0e21e 1525 }
68dc0745 1526 if (!entry) {
a0d0e21e
LW
1527 if (++riter > max)
1528 break;
68dc0745 1529 entry = array[riter];
1c846c1f 1530 }
79072805 1531 }
2f86008e 1532 HvARRAY(hv) = array;
a0d0e21e 1533 (void)hv_iterinit(hv);
79072805
LW
1534}
1535
954c1994
GS
1536/*
1537=for apidoc hv_undef
1538
1539Undefines the hash.
1540
1541=cut
1542*/
1543
79072805 1544void
864dbfa3 1545Perl_hv_undef(pTHX_ HV *hv)
79072805 1546{
cbec9347 1547 register XPVHV* xhv;
79072805
LW
1548 if (!hv)
1549 return;
ecae49c0 1550 DEBUG_A(Perl_hv_assert(aTHX_ hv));
cbec9347 1551 xhv = (XPVHV*)SvANY(hv);
463ee0b2 1552 hfreeentries(hv);
cbec9347 1553 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
85e6fe83 1554 if (HvNAME(hv)) {
7e8961ec
AB
1555 if(PL_stashcache)
1556 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
85e6fe83
LW
1557 Safefree(HvNAME(hv));
1558 HvNAME(hv) = 0;
1559 }
cbec9347
JH
1560 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1561 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
8aacddc1 1562 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
a0d0e21e
LW
1563
1564 if (SvRMAGICAL(hv))
1c846c1f 1565 mg_clear((SV*)hv);
79072805
LW
1566}
1567
954c1994
GS
1568/*
1569=for apidoc hv_iterinit
1570
1571Prepares a starting point to traverse a hash table. Returns the number of
1572keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1c846c1f 1573currently only meaningful for hashes without tie magic.
954c1994
GS
1574
1575NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1576hash buckets that happen to be in use. If you still need that esoteric
1577value, you can get it through the macro C<HvFILL(tb)>.
1578
e16e2ff8 1579
954c1994
GS
1580=cut
1581*/
1582
79072805 1583I32
864dbfa3 1584Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1585{
cbec9347 1586 register XPVHV* xhv;
aa689395
PP
1587 HE *entry;
1588
1589 if (!hv)
cea2e8a9 1590 Perl_croak(aTHX_ "Bad hash");
cbec9347
JH
1591 xhv = (XPVHV*)SvANY(hv);
1592 entry = xhv->xhv_eiter; /* HvEITER(hv) */
72940dca
PP
1593 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1594 HvLAZYDEL_off(hv);
68dc0745 1595 hv_free_ent(hv, entry);
72940dca 1596 }
cbec9347
JH
1597 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1598 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1599 /* used to be xhv->xhv_fill before 5.004_65 */
8aacddc1 1600 return XHvTOTALKEYS(xhv);
79072805 1601}
954c1994
GS
1602/*
1603=for apidoc hv_iternext
1604
1605Returns entries from a hash iterator. See C<hv_iterinit>.
1606
fe7bca90
NC
1607You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1608iterator currently points to, without losing your place or invalidating your
1609iterator. Note that in this case the current entry is deleted from the hash
1610with your iterator holding the last reference to it. Your iterator is flagged
1611to free the entry on the next call to C<hv_iternext>, so you must not discard
1612your iterator immediately else the entry will leak - call C<hv_iternext> to
1613trigger the resource deallocation.
1614
954c1994
GS
1615=cut
1616*/
1617
79072805 1618HE *
864dbfa3 1619Perl_hv_iternext(pTHX_ HV *hv)
79072805 1620{
e16e2ff8
NC
1621 return hv_iternext_flags(hv, 0);
1622}
1623
1624/*
fe7bca90
NC
1625=for apidoc hv_iternext_flags
1626
1627Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1628The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1629set the placeholders keys (for restricted hashes) will be returned in addition
1630to normal keys. By default placeholders are automatically skipped over.
7996736c
MHM
1631Currently a placeholder is implemented with a value that is
1632C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
fe7bca90
NC
1633restricted hashes may change, and the implementation currently is
1634insufficiently abstracted for any change to be tidy.
e16e2ff8 1635
fe7bca90 1636=cut
e16e2ff8
NC
1637*/
1638
1639HE *
1640Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1641{
cbec9347 1642 register XPVHV* xhv;
79072805 1643 register HE *entry;
a0d0e21e 1644 HE *oldentry;
463ee0b2 1645 MAGIC* mg;
79072805
LW
1646
1647 if (!hv)
cea2e8a9 1648 Perl_croak(aTHX_ "Bad hash");
cbec9347
JH
1649 xhv = (XPVHV*)SvANY(hv);
1650 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
463ee0b2 1651
14befaf4 1652 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
8990e307 1653 SV *key = sv_newmortal();
cd1469e6 1654 if (entry) {
fde52b5c 1655 sv_setsv(key, HeSVKEY_force(entry));
cd1469e6
PP
1656 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1657 }
a0d0e21e 1658 else {
ff68c719 1659 char *k;
bbce6d69 1660 HEK *hek;
ff68c719 1661
cbec9347
JH
1662 /* one HE per MAGICAL hash */
1663 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
4633a7c4 1664 Zero(entry, 1, HE);
ff68c719
PP
1665 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1666 hek = (HEK*)k;
1667 HeKEY_hek(entry) = hek;
fde52b5c 1668 HeKLEN(entry) = HEf_SVKEY;
a0d0e21e
LW
1669 }
1670 magic_nextpack((SV*) hv,mg,key);
8aacddc1 1671 if (SvOK(key)) {
cd1469e6 1672 /* force key to stay around until next time */
bbce6d69
PP
1673 HeSVKEY_set(entry, SvREFCNT_inc(key));
1674 return entry; /* beware, hent_val is not set */
8aacddc1 1675 }
fde52b5c
PP
1676 if (HeVAL(entry))
1677 SvREFCNT_dec(HeVAL(entry));
ff68c719 1678 Safefree(HeKEY_hek(entry));
d33b2eba 1679 del_HE(entry);
cbec9347 1680 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
463ee0b2 1681 return Null(HE*);
79072805 1682 }
f675dbe5 1683#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
cbec9347 1684 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
f675dbe5
CB
1685 prime_env_iter();
1686#endif
463ee0b2 1687
cbec9347
JH
1688 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1689 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1690 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1691 char);
015a5f36 1692 /* At start of hash, entry is NULL. */
fde52b5c 1693 if (entry)
8aacddc1 1694 {
fde52b5c 1695 entry = HeNEXT(entry);
e16e2ff8
NC
1696 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1697 /*
1698 * Skip past any placeholders -- don't want to include them in
1699 * any iteration.
1700 */
7996736c 1701 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
e16e2ff8
NC
1702 entry = HeNEXT(entry);
1703 }
8aacddc1
NIS
1704 }
1705 }
fde52b5c 1706 while (!entry) {
015a5f36
NC
1707 /* OK. Come to the end of the current list. Grab the next one. */
1708
cbec9347 1709 xhv->xhv_riter++; /* HvRITER(hv)++ */
eb160463 1710 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
015a5f36 1711 /* There is no next one. End of the hash. */
cbec9347 1712 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
fde52b5c 1713 break;
79072805 1714 }
cbec9347
JH
1715 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1716 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
8aacddc1 1717
e16e2ff8 1718 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
015a5f36
NC
1719 /* If we have an entry, but it's a placeholder, don't count it.
1720 Try the next. */
7996736c 1721 while (entry && HeVAL(entry) == &PL_sv_placeholder)
015a5f36
NC
1722 entry = HeNEXT(entry);
1723 }
1724 /* Will loop again if this linked list starts NULL
1725 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1726 or if we run through it and find only placeholders. */
fde52b5c 1727 }
79072805 1728
72940dca
PP
1729 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1730 HvLAZYDEL_off(hv);
68dc0745 1731 hv_free_ent(hv, oldentry);
72940dca 1732 }
a0d0e21e 1733
fdcd69b6
NC
1734 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1735 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1736
cbec9347 1737 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
79072805
LW
1738 return entry;
1739}
1740
954c1994
GS
1741/*
1742=for apidoc hv_iterkey
1743
1744Returns the key from the current position of the hash iterator. See
1745C<hv_iterinit>.
1746
1747=cut
1748*/
1749
79072805 1750char *
864dbfa3 1751Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 1752{
fde52b5c 1753 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a
PP
1754 STRLEN len;
1755 char *p = SvPV(HeKEY_sv(entry), len);
1756 *retlen = len;
1757 return p;
fde52b5c
PP
1758 }
1759 else {
1760 *retlen = HeKLEN(entry);
1761 return HeKEY(entry);
1762 }
1763}
1764
1765/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994
GS
1766/*
1767=for apidoc hv_iterkeysv
1768
1769Returns the key as an C<SV*> from the current position of the hash
1770iterator. The return value will always be a mortal copy of the key. Also
1771see C<hv_iterinit>.
1772
1773=cut
1774*/
1775
fde52b5c 1776SV *
864dbfa3 1777Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 1778{
19692e8d
NC
1779 if (HeKLEN(entry) != HEf_SVKEY) {
1780 HEK *hek = HeKEY_hek(entry);
1781 int flags = HEK_FLAGS(hek);
1782 SV *sv;
1783
1784 if (flags & HVhek_WASUTF8) {
1785 /* Trouble :-)
1786 Andreas would like keys he put in as utf8 to come back as utf8
1787 */
1788 STRLEN utf8_len = HEK_LEN(hek);
2e5dfef7 1789 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
19692e8d 1790
2e5dfef7 1791 sv = newSVpvn ((char*)as_utf8, utf8_len);
19692e8d 1792 SvUTF8_on (sv);
c193270f 1793 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
4b5190b5
NC
1794 } else if (flags & HVhek_REHASH) {
1795 /* We don't have a pointer to the hv, so we have to replicate the
1796 flag into every HEK. This hv is using custom a hasing
1797 algorithm. Hence we can't return a shared string scalar, as
1798 that would contain the (wrong) hash value, and might get passed
1799 into an hv routine with a regular hash */
1800
1801 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1802 if (HEK_UTF8(hek))
1803 SvUTF8_on (sv);
1804 } else {
19692e8d
NC
1805 sv = newSVpvn_share(HEK_KEY(hek),
1806 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1807 HEK_HASH(hek));
1808 }
1809 return sv_2mortal(sv);
1810 }
1811 return sv_mortalcopy(HeKEY_sv(entry));
79072805
LW
1812}
1813
954c1994
GS
1814/*
1815=for apidoc hv_iterval
1816
1817Returns the value from the current position of the hash iterator. See
1818C<hv_iterkey>.
1819
1820=cut
1821*/
1822
79072805 1823SV *
864dbfa3 1824Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 1825{
8990e307 1826 if (SvRMAGICAL(hv)) {
14befaf4 1827 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
8990e307 1828 SV* sv = sv_newmortal();
bbce6d69
PP
1829 if (HeKLEN(entry) == HEf_SVKEY)
1830 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1831 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2
LW
1832 return sv;
1833 }
79072805 1834 }
fde52b5c 1835 return HeVAL(entry);
79072805
LW
1836}
1837
954c1994
GS
1838/*
1839=for apidoc hv_iternextsv
1840
1841Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1842operation.
1843
1844=cut
1845*/
1846
a0d0e21e 1847SV *
864dbfa3 1848Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e
LW
1849{
1850 HE *he;
e16e2ff8 1851 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
a0d0e21e
LW
1852 return NULL;
1853 *key = hv_iterkey(he, retlen);
1854 return hv_iterval(hv, he);
1855}
1856
954c1994
GS
1857/*
1858=for apidoc hv_magic
1859
1860Adds magic to a hash. See C<sv_magic>.
1861
1862=cut
1863*/
1864
79072805 1865void
864dbfa3 1866Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
79072805 1867{
a0d0e21e 1868 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
79072805 1869}
fde52b5c 1870
37d85e3a
JH
1871#if 0 /* use the macro from hv.h instead */
1872
bbce6d69 1873char*
864dbfa3 1874Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
bbce6d69 1875{
ff68c719 1876 return HEK_KEY(share_hek(sv, len, hash));
bbce6d69
PP
1877}
1878
37d85e3a
JH
1879#endif
1880
bbce6d69 1881/* possibly free a shared string if no one has access to it
fde52b5c
PP
1882 * len and hash must both be valid for str.
1883 */
bbce6d69 1884void
864dbfa3 1885Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 1886{
19692e8d
NC
1887 unshare_hek_or_pvn (NULL, str, len, hash);
1888}
1889
1890
1891void
1892Perl_unshare_hek(pTHX_ HEK *hek)
1893{
1894 unshare_hek_or_pvn(hek, NULL, 0, 0);
1895}
1896
1897/* possibly free a shared string if no one has access to it
1898 hek if non-NULL takes priority over the other 3, else str, len and hash
1899 are used. If so, len and hash must both be valid for str.
1900 */
df132699 1901STATIC void
19692e8d
NC
1902S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
1903{
cbec9347 1904 register XPVHV* xhv;
fde52b5c
PP
1905 register HE *entry;
1906 register HE **oentry;
1907 register I32 i = 1;
1908 I32 found = 0;
c3654f1a 1909 bool is_utf8 = FALSE;
19692e8d 1910 int k_flags = 0;
f9a63242 1911 const char *save = str;
c3654f1a 1912
19692e8d
NC
1913 if (hek) {
1914 hash = HEK_HASH(hek);
1915 } else if (len < 0) {
1916 STRLEN tmplen = -len;
1917 is_utf8 = TRUE;
1918 /* See the note in hv_fetch(). --jhi */
1919 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1920 len = tmplen;
1921 if (is_utf8)
1922 k_flags = HVhek_UTF8;
1923 if (str != save)
1924 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
c3654f1a 1925 }
1c846c1f 1926
fde52b5c 1927 /* what follows is the moral equivalent of:
6b88bc9c 1928 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
bbce6d69 1929 if (--*Svp == Nullsv)
6b88bc9c 1930 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 1931 } */
cbec9347 1932 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 1933 /* assert(xhv_array != 0) */
5f08fbcd 1934 LOCK_STRTAB_MUTEX;
cbec9347
JH
1935 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1936 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
19692e8d
NC
1937 if (hek) {
1938 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1939 if (HeKEY_hek(entry) != hek)
1940 continue;
1941 found = 1;
1942 break;
1943 }
1944 } else {
1945 int flags_masked = k_flags & HVhek_MASK;
1946 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1947 if (HeHASH(entry) != hash) /* strings can't be equal */
1948 continue;
1949 if (HeKLEN(entry) != len)
1950 continue;
1951 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1952 continue;
1953 if (HeKFLAGS(entry) != flags_masked)
1954 continue;
1955 found = 1;
1956 break;
1957 }
1958 }
1959
1960 if (found) {
1961 if (--HeVAL(entry) == Nullsv) {
1962 *oentry = HeNEXT(entry);
1963 if (i && !*oentry)
1964 xhv->xhv_fill--; /* HvFILL(hv)-- */
1965 Safefree(HeKEY_hek(entry));
1966 del_HE(entry);
1967 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1968 }
fde52b5c 1969 }
19692e8d 1970
333f433b 1971 UNLOCK_STRTAB_MUTEX;
411caa50 1972 if (!found && ckWARN_d(WARN_INTERNAL))
19692e8d
NC
1973 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1974 "Attempt to free non-existent shared string '%s'%s",
1975 hek ? HEK_KEY(hek) : str,
1976 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
1977 if (k_flags & HVhek_FREEKEY)
1978 Safefree(str);
fde52b5c
PP
1979}
1980
bbce6d69
PP
1981/* get a (constant) string ptr from the global string table
1982 * string will get added if it is not already there.
fde52b5c
PP
1983 * len and hash must both be valid for str.
1984 */
bbce6d69 1985HEK *
864dbfa3 1986Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 1987{
da58a35d 1988 bool is_utf8 = FALSE;
19692e8d 1989 int flags = 0;
f9a63242 1990 const char *save = str;
da58a35d
JH
1991
1992 if (len < 0) {
77caf834 1993 STRLEN tmplen = -len;
da58a35d 1994 is_utf8 = TRUE;
77caf834
JH
1995 /* See the note in hv_fetch(). --jhi */
1996 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1997 len = tmplen;
19692e8d
NC
1998 /* If we were able to downgrade here, then than means that we were passed
1999 in a key which only had chars 0-255, but was utf8 encoded. */
2000 if (is_utf8)
2001 flags = HVhek_UTF8;
2002 /* If we found we were able to downgrade the string to bytes, then
2003 we should flag that it needs upgrading on keys or each. Also flag
2004 that we need share_hek_flags to free the string. */
2005 if (str != save)
2006 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2007 }
2008
2009 return share_hek_flags (str, len, hash, flags);
2010}
2011
df132699 2012STATIC HEK *
19692e8d
NC
2013S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2014{
2015 register XPVHV* xhv;
2016 register HE *entry;
2017 register HE **oentry;
2018 register I32 i = 1;
2019 I32 found = 0;
2020 int flags_masked = flags & HVhek_MASK;
bbce6d69 2021
fde52b5c 2022 /* what follows is the moral equivalent of:
1c846c1f 2023
6b88bc9c 2024 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
8aacddc1 2025 hv_store(PL_strtab, str, len, Nullsv, hash);
fdcd69b6
NC
2026
2027 Can't rehash the shared string table, so not sure if it's worth
2028 counting the number of entries in the linked list
bbce6d69 2029 */
cbec9347 2030 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2031 /* assert(xhv_array != 0) */
5f08fbcd 2032 LOCK_STRTAB_MUTEX;
cbec9347
JH
2033 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2034 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 2035 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
fde52b5c
PP
2036 if (HeHASH(entry) != hash) /* strings can't be equal */
2037 continue;
2038 if (HeKLEN(entry) != len)
2039 continue;
1c846c1f 2040 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 2041 continue;
19692e8d 2042 if (HeKFLAGS(entry) != flags_masked)
c3654f1a 2043 continue;
fde52b5c 2044 found = 1;
fde52b5c
PP
2045 break;
2046 }
bbce6d69 2047 if (!found) {
d33b2eba 2048 entry = new_HE();
19692e8d 2049 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
bbce6d69
PP
2050 HeVAL(entry) = Nullsv;
2051 HeNEXT(entry) = *oentry;
2052 *oentry = entry;
cbec9347 2053 xhv->xhv_keys++; /* HvKEYS(hv)++ */
bbce6d69 2054 if (i) { /* initial entry? */
cbec9347 2055 xhv->xhv_fill++; /* HvFILL(hv)++ */
4c9cc595 2056 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
cbec9347 2057 hsplit(PL_strtab);
bbce6d69
PP
2058 }
2059 }
2060
2061 ++HeVAL(entry); /* use value slot as REFCNT */
5f08fbcd 2062 UNLOCK_STRTAB_MUTEX;
19692e8d
NC
2063
2064 if (flags & HVhek_FREEKEY)
f9a63242 2065 Safefree(str);
19692e8d 2066
ff68c719 2067 return HeKEY_hek(entry);
fde52b5c 2068}
ecae49c0
NC
2069
2070
2071/*
2072=for apidoc hv_assert
2073
2074Check that a hash is in an internally consistent state.
2075
2076=cut
2077*/
2078
2079void
2080Perl_hv_assert(pTHX_ HV *hv)
2081{
2082 HE* entry;
2083 int withflags = 0;
2084 int placeholders = 0;
2085 int real = 0;
2086 int bad = 0;
2087 I32 riter = HvRITER(hv);
2088 HE *eiter = HvEITER(hv);
2089
2090 (void)hv_iterinit(hv);
2091
2092 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2093 /* sanity check the values */
2094 if (HeVAL(entry) == &PL_sv_placeholder) {
2095 placeholders++;
2096 } else {
2097 real++;
2098 }
2099 /* sanity check the keys */
2100 if (HeSVKEY(entry)) {
2101 /* Don't know what to check on SV keys. */
2102 } else if (HeKUTF8(entry)) {
2103 withflags++;
2104 if (HeKWASUTF8(entry)) {
2105 PerlIO_printf(Perl_debug_log,
2106 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2107 (int) HeKLEN(entry), HeKEY(entry));
2108 bad = 1;
2109 }
2110 } else if (HeKWASUTF8(entry)) {
2111 withflags++;
2112 }
2113 }
2114 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2115 if (HvUSEDKEYS(hv) != real) {
2116 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2117 (int) real, (int) HvUSEDKEYS(hv));
2118 bad = 1;
2119 }
2120 if (HvPLACEHOLDERS(hv) != placeholders) {
2121 PerlIO_printf(Perl_debug_log,
2122 "Count %d placeholder(s), but hash reports %d\n",
2123 (int) placeholders, (int) HvPLACEHOLDERS(hv));
2124 bad = 1;
2125 }
2126 }
2127 if (withflags && ! HvHASKFLAGS(hv)) {
2128 PerlIO_printf(Perl_debug_log,
2129 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2130 withflags);
2131 bad = 1;
2132 }
2133 if (bad) {
2134 sv_dump((SV *)hv);
2135 }
2136 HvRITER(hv) = riter; /* Restore hash iterator state */
2137 HvEITER(hv) = eiter;
2138}