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