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