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