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