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