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