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