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