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