This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ex-PVBM and mro interact badly
[perl5.git] / hv.c
CommitLineData
a0d0e21e 1/* hv.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
7272f7c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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
d75ce684 36static const char S_strtab_error[]
5d2b1485
NC
37 = "Cannot modify shared string table in hv_%s";
38
cac9b346
NC
39STATIC void
40S_more_he(pTHX)
41{
97aff369 42 dVAR;
1e05feb3
AL
43 HE* he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT);
44 HE * const heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
cac9b346 45
d2a0f284 46 PL_body_roots[HE_SVSLOT] = he;
cac9b346
NC
47 while (he < heend) {
48 HeNEXT(he) = (HE*)(he + 1);
49 he++;
50 }
51 HeNEXT(he) = 0;
52}
53
c941fb51
NC
54#ifdef PURIFY
55
56#define new_HE() (HE*)safemalloc(sizeof(HE))
57#define del_HE(p) safefree((char*)p)
58
59#else
60
76e3520e 61STATIC HE*
cea2e8a9 62S_new_he(pTHX)
4633a7c4 63{
97aff369 64 dVAR;
4633a7c4 65 HE* he;
0bd48802 66 void ** const root = &PL_body_roots[HE_SVSLOT];
6a93a7e5 67
6a93a7e5 68 if (!*root)
cac9b346 69 S_more_he(aTHX);
10edeb5d 70 he = (HE*) *root;
ce3e5c45 71 assert(he);
6a93a7e5 72 *root = HeNEXT(he);
333f433b 73 return he;
4633a7c4
LW
74}
75
c941fb51
NC
76#define new_HE() new_he()
77#define del_HE(p) \
78 STMT_START { \
6a93a7e5
NC
79 HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
80 PL_body_roots[HE_SVSLOT] = p; \
c941fb51 81 } STMT_END
d33b2eba 82
d33b2eba 83
d33b2eba
GS
84
85#endif
86
76e3520e 87STATIC HEK *
5f66b61c 88S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
bbce6d69 89{
35a4481c 90 const int flags_masked = flags & HVhek_MASK;
bbce6d69
PP
91 char *k;
92 register HEK *hek;
1c846c1f 93
a02a5408 94 Newx(k, HEK_BASESIZE + len + 2, char);
bbce6d69 95 hek = (HEK*)k;
ff68c719 96 Copy(str, HEK_KEY(hek), len, char);
e05949c7 97 HEK_KEY(hek)[len] = 0;
ff68c719
PP
98 HEK_LEN(hek) = len;
99 HEK_HASH(hek) = hash;
45e34800 100 HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
dcf933a4
NC
101
102 if (flags & HVhek_FREEKEY)
103 Safefree(str);
bbce6d69
PP
104 return hek;
105}
106
4a31713e 107/* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
dd28f7bb
DM
108 * for tied hashes */
109
110void
111Perl_free_tied_hv_pool(pTHX)
112{
97aff369 113 dVAR;
dd28f7bb
DM
114 HE *he = PL_hv_fetch_ent_mh;
115 while (he) {
9d4ba2ae 116 HE * const ohe = he;
dd28f7bb 117 Safefree(HeKEY_hek(he));
dd28f7bb
DM
118 he = HeNEXT(he);
119 del_HE(ohe);
120 }
4608196e 121 PL_hv_fetch_ent_mh = NULL;
dd28f7bb
DM
122}
123
d18c6117 124#if defined(USE_ITHREADS)
0bff533c
NC
125HEK *
126Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
127{
658b4a4a 128 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
9d4ba2ae
AL
129
130 PERL_UNUSED_ARG(param);
0bff533c
NC
131
132 if (shared) {
133 /* We already shared this hash key. */
454f1e26 134 (void)share_hek_hek(shared);
0bff533c
NC
135 }
136 else {
658b4a4a 137 shared
6e838c70
NC
138 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
139 HEK_HASH(source), HEK_FLAGS(source));
658b4a4a 140 ptr_table_store(PL_ptr_table, source, shared);
0bff533c 141 }
658b4a4a 142 return shared;
0bff533c
NC
143}
144
d18c6117 145HE *
5c4138a0 146Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
d18c6117
GS
147{
148 HE *ret;
149
150 if (!e)
4608196e 151 return NULL;
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;
a02a5408 164 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
dd28f7bb 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. */
1b6737cc 171 HEK * const 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. */
454f1e26 176 (void)share_hek_hek(shared);
c21d1a0f
NC
177 }
178 else {
658b4a4a 179 shared
6e838c70
NC
180 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
181 HEK_HASH(source), HEK_FLAGS(source));
658b4a4a 182 ptr_table_store(PL_ptr_table, source, shared);
c21d1a0f 183 }
658b4a4a 184 HeKEY_hek(ret) = shared;
c21d1a0f 185 }
d18c6117 186 else
19692e8d
NC
187 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
188 HeKFLAGS(e));
d2d73c3e 189 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
d18c6117
GS
190 return ret;
191}
192#endif /* USE_ITHREADS */
193
1b1f1335 194static void
2393f1b9
JH
195S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
196 const char *msg)
1b1f1335 197{
1b6737cc 198 SV * const sv = sv_newmortal();
19692e8d 199 if (!(flags & HVhek_FREEKEY)) {
1b1f1335
NIS
200 sv_setpvn(sv, key, klen);
201 }
202 else {
203 /* Need to free saved eventually assign to mortal SV */
34c3c4e3 204 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
1b1f1335
NIS
205 sv_usepvn(sv, (char *) key, klen);
206 }
19692e8d 207 if (flags & HVhek_UTF8) {
1b1f1335
NIS
208 SvUTF8_on(sv);
209 }
be2597df 210 Perl_croak(aTHX_ msg, SVfARG(sv));
1b1f1335
NIS
211}
212
fde52b5c
PP
213/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
214 * contains an SV* */
215
34a6f7b4
NC
216/*
217=for apidoc hv_store
218
219Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
220the length of the key. The C<hash> parameter is the precomputed hash
221value; if it is zero then Perl will compute it. The return value will be
222NULL if the operation failed or if the value did not need to be actually
223stored within the hash (as in the case of tied hashes). Otherwise it can
224be dereferenced to get the original C<SV*>. Note that the caller is
225responsible for suitably incrementing the reference count of C<val> before
226the call, and decrementing it if the function returned NULL. Effectively
227a successful hv_store takes ownership of one reference to C<val>. This is
228usually what you want; a newly created SV has a reference count of one, so
229if all your code does is create SVs then store them in a hash, hv_store
230will own the only reference to the new SV, and your code doesn't need to do
231anything further to tidy up. hv_store is not implemented as a call to
232hv_store_ent, and does not create a temporary SV for the key, so if your
233key data is not already in SV form then use hv_store in preference to
234hv_store_ent.
235
236See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
237information on how to use this function on tied hashes.
238
34a6f7b4
NC
239=for apidoc hv_store_ent
240
241Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
242parameter is the precomputed hash value; if it is zero then Perl will
243compute it. The return value is the new hash entry so created. It will be
244NULL if the operation failed or if the value did not need to be actually
245stored within the hash (as in the case of tied hashes). Otherwise the
246contents of the return value can be accessed using the C<He?> macros
247described here. Note that the caller is responsible for suitably
248incrementing the reference count of C<val> before the call, and
249decrementing it if the function returned NULL. Effectively a successful
250hv_store_ent takes ownership of one reference to C<val>. This is
251usually what you want; a newly created SV has a reference count of one, so
252if all your code does is create SVs then store them in a hash, hv_store
253will own the only reference to the new SV, and your code doesn't need to do
254anything further to tidy up. Note that hv_store_ent only reads the C<key>;
255unlike C<val> it does not take ownership of it, so maintaining the correct
256reference count on C<key> is entirely the caller's responsibility. hv_store
257is not implemented as a call to hv_store_ent, and does not create a temporary
258SV for the key, so if your key data is not already in SV form then use
259hv_store in preference to hv_store_ent.
260
261See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
262information on how to use this function on tied hashes.
263
34a6f7b4
NC
264=for apidoc hv_exists
265
266Returns a boolean indicating whether the specified hash key exists. The
267C<klen> is the length of the key.
268
954c1994
GS
269=for apidoc hv_fetch
270
271Returns the SV which corresponds to the specified key in the hash. The
272C<klen> is the length of the key. If C<lval> is set then the fetch will be
273part of a store. Check that the return value is non-null before
d1be9408 274dereferencing it to an C<SV*>.
954c1994 275
96f1132b 276See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
277information on how to use this function on tied hashes.
278
34a6f7b4
NC
279=for apidoc hv_exists_ent
280
281Returns a boolean indicating whether the specified hash key exists. C<hash>
282can be a valid precomputed hash value, or 0 to ask for it to be
283computed.
284
285=cut
286*/
287
d1be9408 288/* returns an HE * structure with the all fields set */
fde52b5c 289/* note that hent_val will be a mortal sv for MAGICAL hashes */
954c1994
GS
290/*
291=for apidoc hv_fetch_ent
292
293Returns the hash entry which corresponds to the specified key in the hash.
294C<hash> must be a valid precomputed hash number for the given C<key>, or 0
295if you want the function to compute it. IF C<lval> is set then the fetch
296will be part of a store. Make sure the return value is non-null before
297accessing it. The return value when C<tb> is a tied hash is a pointer to a
298static location, so be sure to make a copy of the structure if you need to
1c846c1f 299store it somewhere.
954c1994 300
96f1132b 301See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
302information on how to use this function on tied hashes.
303
304=cut
305*/
306
a038e571
NC
307/* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */
308void *
309Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
310 const int action, SV *val, const U32 hash)
311{
312 STRLEN klen;
313 int flags;
314
315 if (klen_i32 < 0) {
316 klen = -klen_i32;
317 flags = HVhek_UTF8;
318 } else {
319 klen = klen_i32;
320 flags = 0;
321 }
322 return hv_common(hv, NULL, key, klen, flags, action, val, hash);
323}
324
63c89345 325void *
d3ba3f5c
NC
326Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
327 int flags, int action, SV *val, register U32 hash)
113738bb 328{
27da23d5 329 dVAR;
b2c64049 330 XPVHV* xhv;
b2c64049
NC
331 HE *entry;
332 HE **oentry;
fde52b5c 333 SV *sv;
da58a35d 334 bool is_utf8;
113738bb 335 int masked_flags;
3c84c864 336 const int return_svp = action & HV_FETCH_JUST_SV;
fde52b5c
PP
337
338 if (!hv)
a4fc7abc 339 return NULL;
8265e3d1
NC
340 if (SvTYPE(hv) == SVTYPEMASK)
341 return NULL;
342
343 assert(SvTYPE(hv) == SVt_PVHV);
fde52b5c 344
bdee33e4 345 if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
fda2d18a
NC
346 MAGIC* mg;
347 if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
348 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
349 if (uf->uf_set == NULL) {
350 SV* obj = mg->mg_obj;
351
352 if (!keysv) {
353 keysv = sv_2mortal(newSVpvn(key, klen));
354 if (flags & HVhek_UTF8)
355 SvUTF8_on(keysv);
356 }
357
358 mg->mg_obj = keysv; /* pass key */
359 uf->uf_index = action; /* pass action */
360 magic_getuvar((SV*)hv, mg);
361 keysv = mg->mg_obj; /* may have changed */
362 mg->mg_obj = obj;
363
364 /* If the key may have changed, then we need to invalidate
365 any passed-in computed hash value. */
366 hash = 0;
367 }
368 }
bdee33e4 369 }
113738bb 370 if (keysv) {
e593d2fe
AE
371 if (flags & HVhek_FREEKEY)
372 Safefree(key);
5c144d81 373 key = SvPV_const(keysv, klen);
c1fe5510 374 flags = 0;
113738bb
NC
375 is_utf8 = (SvUTF8(keysv) != 0);
376 } else {
c1fe5510 377 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
113738bb 378 }
113738bb 379
9dbc5603 380 if (action & HV_DELETE) {
3c84c864
NC
381 return (void *) hv_delete_common(hv, keysv, key, klen,
382 flags | (is_utf8 ? HVhek_UTF8 : 0),
383 action, hash);
9dbc5603
NC
384 }
385
b2c64049 386 xhv = (XPVHV*)SvANY(hv);
7f66fda2 387 if (SvMAGICAL(hv)) {
6136c704 388 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
44a2ac75 389 if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv))
e62cc96a 390 {
3c84c864 391 /* FIXME should be able to skimp on the HE/HEK here when
7f66fda2 392 HV_FETCH_JUST_SV is true. */
7f66fda2
NC
393 if (!keysv) {
394 keysv = newSVpvn(key, klen);
395 if (is_utf8) {
396 SvUTF8_on(keysv);
397 }
398 } else {
399 keysv = newSVsv(keysv);
113738bb 400 }
44a2ac75
YO
401 sv = sv_newmortal();
402 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
7f66fda2
NC
403
404 /* grab a fake HE/HEK pair from the pool or make a new one */
405 entry = PL_hv_fetch_ent_mh;
406 if (entry)
407 PL_hv_fetch_ent_mh = HeNEXT(entry);
408 else {
409 char *k;
410 entry = new_HE();
a02a5408 411 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
7f66fda2
NC
412 HeKEY_hek(entry) = (HEK*)k;
413 }
4608196e 414 HeNEXT(entry) = NULL;
7f66fda2
NC
415 HeSVKEY_set(entry, keysv);
416 HeVAL(entry) = sv;
417 sv_upgrade(sv, SVt_PVLV);
418 LvTYPE(sv) = 'T';
419 /* so we can free entry when freeing sv */
420 LvTARG(sv) = (SV*)entry;
421
422 /* XXX remove at some point? */
423 if (flags & HVhek_FREEKEY)
424 Safefree(key);
425
3c84c864
NC
426 if (return_svp) {
427 return entry ? (void *) &HeVAL(entry) : NULL;
428 }
429 return (void *) entry;
113738bb 430 }
7f66fda2
NC
431#ifdef ENV_IS_CASELESS
432 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
433 U32 i;
434 for (i = 0; i < klen; ++i)
435 if (isLOWER(key[i])) {
086cb327
NC
436 /* Would be nice if we had a routine to do the
437 copy and upercase in a single pass through. */
0bd48802 438 const char * const nkey = strupr(savepvn(key,klen));
086cb327
NC
439 /* Note that this fetch is for nkey (the uppercased
440 key) whereas the store is for key (the original) */
63c89345
NC
441 void *result = hv_common(hv, NULL, nkey, klen,
442 HVhek_FREEKEY, /* free nkey */
443 0 /* non-LVAL fetch */
3c84c864
NC
444 | HV_DISABLE_UVAR_XKEY
445 | return_svp,
63c89345
NC
446 NULL /* no value */,
447 0 /* compute hash */);
26488bcf 448 if (!result && (action & HV_FETCH_LVALUE)) {
086cb327
NC
449 /* This call will free key if necessary.
450 Do it this way to encourage compiler to tail
451 call optimise. */
63c89345
NC
452 result = hv_common(hv, keysv, key, klen, flags,
453 HV_FETCH_ISSTORE
3c84c864
NC
454 | HV_DISABLE_UVAR_XKEY
455 | return_svp,
63c89345 456 newSV(0), hash);
086cb327
NC
457 } else {
458 if (flags & HVhek_FREEKEY)
459 Safefree(key);
460 }
63c89345 461 return result;
7f66fda2 462 }
902173a3 463 }
7f66fda2
NC
464#endif
465 } /* ISFETCH */
466 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
467 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
b2c64049
NC
468 /* I don't understand why hv_exists_ent has svret and sv,
469 whereas hv_exists only had one. */
9d4ba2ae 470 SV * const svret = sv_newmortal();
b2c64049 471 sv = sv_newmortal();
7f66fda2
NC
472
473 if (keysv || is_utf8) {
474 if (!keysv) {
475 keysv = newSVpvn(key, klen);
476 SvUTF8_on(keysv);
477 } else {
478 keysv = newSVsv(keysv);
479 }
b2c64049
NC
480 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
481 } else {
482 mg_copy((SV*)hv, sv, key, klen);
7f66fda2 483 }
b2c64049
NC
484 if (flags & HVhek_FREEKEY)
485 Safefree(key);
7f66fda2
NC
486 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
487 /* This cast somewhat evil, but I'm merely using NULL/
488 not NULL to return the boolean exists.
489 And I know hv is not NULL. */
3c84c864 490 return SvTRUE(svret) ? (void *)hv : NULL;
e7152ba2 491 }
7f66fda2
NC
492#ifdef ENV_IS_CASELESS
493 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
494 /* XXX This code isn't UTF8 clean. */
a15d23f8 495 char * const keysave = (char * const)key;
b2c64049
NC
496 /* Will need to free this, so set FREEKEY flag. */
497 key = savepvn(key,klen);
498 key = (const char*)strupr((char*)key);
6136c704 499 is_utf8 = FALSE;
7f66fda2 500 hash = 0;
8b4f7dd5 501 keysv = 0;
b2c64049
NC
502
503 if (flags & HVhek_FREEKEY) {
504 Safefree(keysave);
505 }
506 flags |= HVhek_FREEKEY;
7f66fda2 507 }
902173a3 508#endif
7f66fda2 509 } /* ISEXISTS */
b2c64049
NC
510 else if (action & HV_FETCH_ISSTORE) {
511 bool needs_copy;
512 bool needs_store;
513 hv_magic_check (hv, &needs_copy, &needs_store);
514 if (needs_copy) {
a3b680e6 515 const bool save_taint = PL_tainted;
b2c64049
NC
516 if (keysv || is_utf8) {
517 if (!keysv) {
518 keysv = newSVpvn(key, klen);
519 SvUTF8_on(keysv);
520 }
521 if (PL_tainting)
522 PL_tainted = SvTAINTED(keysv);
523 keysv = sv_2mortal(newSVsv(keysv));
524 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
525 } else {
526 mg_copy((SV*)hv, val, key, klen);
527 }
528
529 TAINT_IF(save_taint);
1baaf5d7 530 if (!needs_store) {
b2c64049
NC
531 if (flags & HVhek_FREEKEY)
532 Safefree(key);
4608196e 533 return NULL;
b2c64049
NC
534 }
535#ifdef ENV_IS_CASELESS
536 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
537 /* XXX This code isn't UTF8 clean. */
538 const char *keysave = key;
539 /* Will need to free this, so set FREEKEY flag. */
540 key = savepvn(key,klen);
541 key = (const char*)strupr((char*)key);
6136c704 542 is_utf8 = FALSE;
b2c64049 543 hash = 0;
8b4f7dd5 544 keysv = 0;
b2c64049
NC
545
546 if (flags & HVhek_FREEKEY) {
547 Safefree(keysave);
548 }
549 flags |= HVhek_FREEKEY;
550 }
551#endif
552 }
553 } /* ISSTORE */
7f66fda2 554 } /* SvMAGICAL */
fde52b5c 555
7b2c381c 556 if (!HvARRAY(hv)) {
b2c64049 557 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
fde52b5c 558#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
8aacddc1 559 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
fde52b5c 560#endif
d58e6666
NC
561 ) {
562 char *array;
a02a5408 563 Newxz(array,
cbec9347 564 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
d58e6666
NC
565 char);
566 HvARRAY(hv) = (HE**)array;
567 }
7f66fda2
NC
568#ifdef DYNAMIC_ENV_FETCH
569 else if (action & HV_FETCH_ISEXISTS) {
570 /* for an %ENV exists, if we do an insert it's by a recursive
571 store call, so avoid creating HvARRAY(hv) right now. */
572 }
573#endif
113738bb
NC
574 else {
575 /* XXX remove at some point? */
576 if (flags & HVhek_FREEKEY)
577 Safefree(key);
578
3c84c864 579 return NULL;
113738bb 580 }
fde52b5c
PP
581 }
582
19692e8d 583 if (is_utf8) {
41d88b63 584 char * const keysave = (char *)key;
f9a63242 585 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
19692e8d 586 if (is_utf8)
c1fe5510
NC
587 flags |= HVhek_UTF8;
588 else
589 flags &= ~HVhek_UTF8;
7f66fda2
NC
590 if (key != keysave) {
591 if (flags & HVhek_FREEKEY)
592 Safefree(keysave);
19692e8d 593 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
7f66fda2 594 }
19692e8d 595 }
f9a63242 596
4b5190b5
NC
597 if (HvREHASH(hv)) {
598 PERL_HASH_INTERNAL(hash, key, klen);
b2c64049
NC
599 /* We don't have a pointer to the hv, so we have to replicate the
600 flag into every HEK, so that hv_iterkeysv can see it. */
601 /* And yes, you do need this even though you are not "storing" because
fdcd69b6
NC
602 you can flip the flags below if doing an lval lookup. (And that
603 was put in to give the semantics Andreas was expecting.) */
604 flags |= HVhek_REHASH;
4b5190b5 605 } else if (!hash) {
113738bb 606 if (keysv && (SvIsCOW_shared_hash(keysv))) {
c158a4fd 607 hash = SvSHARED_HASH(keysv);
46187eeb
NC
608 } else {
609 PERL_HASH(hash, key, klen);
610 }
611 }
effa1e2d 612
113738bb
NC
613 masked_flags = (flags & HVhek_MASK);
614
7f66fda2 615#ifdef DYNAMIC_ENV_FETCH
4608196e 616 if (!HvARRAY(hv)) entry = NULL;
7f66fda2
NC
617 else
618#endif
b2c64049 619 {
7b2c381c 620 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
b2c64049 621 }
0298d7b9 622 for (; entry; entry = HeNEXT(entry)) {
fde52b5c
PP
623 if (HeHASH(entry) != hash) /* strings can't be equal */
624 continue;
eb160463 625 if (HeKLEN(entry) != (I32)klen)
fde52b5c 626 continue;
1c846c1f 627 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 628 continue;
113738bb 629 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 630 continue;
b2c64049
NC
631
632 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
633 if (HeKFLAGS(entry) != masked_flags) {
634 /* We match if HVhek_UTF8 bit in our flags and hash key's
635 match. But if entry was set previously with HVhek_WASUTF8
636 and key now doesn't (or vice versa) then we should change
637 the key's flag, as this is assignment. */
638 if (HvSHAREKEYS(hv)) {
639 /* Need to swap the key we have for a key with the flags we
640 need. As keys are shared we can't just write to the
641 flag, so we share the new one, unshare the old one. */
6136c704 642 HEK * const new_hek = share_hek_flags(key, klen, hash,
6e838c70 643 masked_flags);
b2c64049
NC
644 unshare_hek (HeKEY_hek(entry));
645 HeKEY_hek(entry) = new_hek;
646 }
5d2b1485
NC
647 else if (hv == PL_strtab) {
648 /* PL_strtab is usually the only hash without HvSHAREKEYS,
649 so putting this test here is cheap */
650 if (flags & HVhek_FREEKEY)
651 Safefree(key);
652 Perl_croak(aTHX_ S_strtab_error,
653 action & HV_FETCH_LVALUE ? "fetch" : "store");
654 }
b2c64049
NC
655 else
656 HeKFLAGS(entry) = masked_flags;
657 if (masked_flags & HVhek_ENABLEHVKFLAGS)
658 HvHASKFLAGS_on(hv);
659 }
660 if (HeVAL(entry) == &PL_sv_placeholder) {
661 /* yes, can store into placeholder slot */
662 if (action & HV_FETCH_LVALUE) {
663 if (SvMAGICAL(hv)) {
664 /* This preserves behaviour with the old hv_fetch
665 implementation which at this point would bail out
666 with a break; (at "if we find a placeholder, we
667 pretend we haven't found anything")
668
669 That break mean that if a placeholder were found, it
670 caused a call into hv_store, which in turn would
671 check magic, and if there is no magic end up pretty
672 much back at this point (in hv_store's code). */
673 break;
674 }
675 /* LVAL fetch which actaully needs a store. */
561b68a9 676 val = newSV(0);
ca732855 677 HvPLACEHOLDERS(hv)--;
b2c64049
NC
678 } else {
679 /* store */
680 if (val != &PL_sv_placeholder)
ca732855 681 HvPLACEHOLDERS(hv)--;
b2c64049
NC
682 }
683 HeVAL(entry) = val;
684 } else if (action & HV_FETCH_ISSTORE) {
685 SvREFCNT_dec(HeVAL(entry));
686 HeVAL(entry) = val;
687 }
27bcc0a7 688 } else if (HeVAL(entry) == &PL_sv_placeholder) {
b2c64049
NC
689 /* if we find a placeholder, we pretend we haven't found
690 anything */
8aacddc1 691 break;
b2c64049 692 }
113738bb
NC
693 if (flags & HVhek_FREEKEY)
694 Safefree(key);
3c84c864
NC
695 if (return_svp) {
696 return entry ? (void *) &HeVAL(entry) : NULL;
697 }
fde52b5c
PP
698 return entry;
699 }
700#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
0ed29950
NC
701 if (!(action & HV_FETCH_ISSTORE)
702 && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364 703 unsigned long len;
9d4ba2ae 704 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
a6c40364
GS
705 if (env) {
706 sv = newSVpvn(env,len);
707 SvTAINTED_on(sv);
d3ba3f5c 708 return hv_common(hv, keysv, key, klen, flags,
3c84c864
NC
709 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
710 sv, hash);
a6c40364 711 }
fde52b5c
PP
712 }
713#endif
7f66fda2
NC
714
715 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
c445ea15 716 hv_notallowed(flags, key, klen,
c8cd6465
NC
717 "Attempt to access disallowed key '%"SVf"' in"
718 " a restricted hash");
1b1f1335 719 }
b2c64049
NC
720 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
721 /* Not doing some form of store, so return failure. */
722 if (flags & HVhek_FREEKEY)
723 Safefree(key);
3c84c864 724 return NULL;
b2c64049 725 }
113738bb 726 if (action & HV_FETCH_LVALUE) {
561b68a9 727 val = newSV(0);
b2c64049
NC
728 if (SvMAGICAL(hv)) {
729 /* At this point the old hv_fetch code would call to hv_store,
730 which in turn might do some tied magic. So we need to make that
731 magic check happen. */
732 /* gonna assign to this, so it better be there */
fda2d18a
NC
733 /* If a fetch-as-store fails on the fetch, then the action is to
734 recurse once into "hv_store". If we didn't do this, then that
735 recursive call would call the key conversion routine again.
736 However, as we replace the original key with the converted
737 key, this would result in a double conversion, which would show
738 up as a bug if the conversion routine is not idempotent. */
d3ba3f5c 739 return hv_common(hv, keysv, key, klen, flags,
3c84c864
NC
740 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
741 val, hash);
b2c64049
NC
742 /* XXX Surely that could leak if the fetch-was-store fails?
743 Just like the hv_fetch. */
113738bb
NC
744 }
745 }
746
b2c64049
NC
747 /* Welcome to hv_store... */
748
7b2c381c 749 if (!HvARRAY(hv)) {
b2c64049
NC
750 /* Not sure if we can get here. I think the only case of oentry being
751 NULL is for %ENV with dynamic env fetch. But that should disappear
752 with magic in the previous code. */
d58e6666 753 char *array;
a02a5408 754 Newxz(array,
b2c64049 755 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
d58e6666
NC
756 char);
757 HvARRAY(hv) = (HE**)array;
b2c64049
NC
758 }
759
7b2c381c 760 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
ab4af705 761
b2c64049
NC
762 entry = new_HE();
763 /* share_hek_flags will do the free for us. This might be considered
764 bad API design. */
765 if (HvSHAREKEYS(hv))
6e838c70 766 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
5d2b1485
NC
767 else if (hv == PL_strtab) {
768 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
769 this test here is cheap */
770 if (flags & HVhek_FREEKEY)
771 Safefree(key);
772 Perl_croak(aTHX_ S_strtab_error,
773 action & HV_FETCH_LVALUE ? "fetch" : "store");
774 }
b2c64049
NC
775 else /* gotta do the real thing */
776 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
777 HeVAL(entry) = val;
778 HeNEXT(entry) = *oentry;
779 *oentry = entry;
780
781 if (val == &PL_sv_placeholder)
ca732855 782 HvPLACEHOLDERS(hv)++;
b2c64049
NC
783 if (masked_flags & HVhek_ENABLEHVKFLAGS)
784 HvHASKFLAGS_on(hv);
785
0298d7b9
NC
786 {
787 const HE *counter = HeNEXT(entry);
788
4c7185a0 789 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
0298d7b9
NC
790 if (!counter) { /* initial entry? */
791 xhv->xhv_fill++; /* HvFILL(hv)++ */
792 } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
793 hsplit(hv);
794 } else if(!HvREHASH(hv)) {
795 U32 n_links = 1;
796
797 while ((counter = HeNEXT(counter)))
798 n_links++;
799
800 if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
801 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
802 bucket splits on a rehashed hash, as we're not going to
803 split it again, and if someone is lucky (evil) enough to
804 get all the keys in one list they could exhaust our memory
805 as we repeatedly double the number of buckets on every
806 entry. Linear search feels a less worse thing to do. */
807 hsplit(hv);
808 }
809 }
fde52b5c 810 }
b2c64049 811
3c84c864
NC
812 if (return_svp) {
813 return entry ? (void *) &HeVAL(entry) : NULL;
814 }
815 return (void *) entry;
fde52b5c
PP
816}
817
864dbfa3 818STATIC void
b0e6ae5b 819S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
d0066dc7 820{
a3b680e6 821 const MAGIC *mg = SvMAGIC(hv);
d0066dc7
OT
822 *needs_copy = FALSE;
823 *needs_store = TRUE;
824 while (mg) {
825 if (isUPPER(mg->mg_type)) {
826 *needs_copy = TRUE;
d60c5a05 827 if (mg->mg_type == PERL_MAGIC_tied) {
d0066dc7 828 *needs_store = FALSE;
4ab2a30b 829 return; /* We've set all there is to set. */
d0066dc7
OT
830 }
831 }
832 mg = mg->mg_moremagic;
833 }
834}
835
954c1994 836/*
a3bcc51e
TP
837=for apidoc hv_scalar
838
839Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
840
841=cut
842*/
843
844SV *
845Perl_hv_scalar(pTHX_ HV *hv)
846{
a3bcc51e 847 SV *sv;
823a54a3
AL
848
849 if (SvRMAGICAL(hv)) {
850 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
851 if (mg)
852 return magic_scalarpack(hv, mg);
853 }
a3bcc51e
TP
854
855 sv = sv_newmortal();
856 if (HvFILL((HV*)hv))
857 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
858 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
859 else
860 sv_setiv(sv, 0);
861
862 return sv;
863}
864
865/*
954c1994
GS
866=for apidoc hv_delete
867
868Deletes a key/value pair in the hash. The value SV is removed from the
1c846c1f 869hash and returned to the caller. The C<klen> is the length of the key.
954c1994
GS
870The C<flags> value will normally be zero; if set to G_DISCARD then NULL
871will be returned.
872
954c1994
GS
873=for apidoc hv_delete_ent
874
875Deletes a key/value pair in the hash. The value SV is removed from the
876hash and returned to the caller. The C<flags> value will normally be zero;
877if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
878precomputed hash value, or 0 to ask for it to be computed.
879
880=cut
881*/
882
8f8d40ab 883STATIC SV *
cd6d36ac
NC
884S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
885 int k_flags, I32 d_flags, U32 hash)
f1317c8d 886{
27da23d5 887 dVAR;
cbec9347 888 register XPVHV* xhv;
fde52b5c
PP
889 register HE *entry;
890 register HE **oentry;
9e720f71 891 HE *const *first_entry;
9dbc5603 892 bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
7a9669ca 893 int masked_flags;
1c846c1f 894
fde52b5c 895 if (SvRMAGICAL(hv)) {
0a0bb7c7
OT
896 bool needs_copy;
897 bool needs_store;
898 hv_magic_check (hv, &needs_copy, &needs_store);
899
f1317c8d 900 if (needs_copy) {
6136c704 901 SV *sv;
63c89345
NC
902 entry = (HE *) hv_common(hv, keysv, key, klen,
903 k_flags & ~HVhek_FREEKEY,
904 HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
905 NULL, hash);
7a9669ca 906 sv = entry ? HeVAL(entry) : NULL;
f1317c8d
NC
907 if (sv) {
908 if (SvMAGICAL(sv)) {
909 mg_clear(sv);
910 }
911 if (!needs_store) {
912 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
913 /* No longer an element */
914 sv_unmagic(sv, PERL_MAGIC_tiedelem);
915 return sv;
916 }
a0714e2c 917 return NULL; /* element cannot be deleted */
f1317c8d 918 }
902173a3 919#ifdef ENV_IS_CASELESS
8167a60a
NC
920 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
921 /* XXX This code isn't UTF8 clean. */
922 keysv = sv_2mortal(newSVpvn(key,klen));
923 if (k_flags & HVhek_FREEKEY) {
924 Safefree(key);
925 }
926 key = strupr(SvPVX(keysv));
927 is_utf8 = 0;
928 k_flags = 0;
929 hash = 0;
7f66fda2 930 }
510ac311 931#endif
2fd1c6b8 932 }
2fd1c6b8 933 }
fde52b5c 934 }
cbec9347 935 xhv = (XPVHV*)SvANY(hv);
7b2c381c 936 if (!HvARRAY(hv))
a0714e2c 937 return NULL;
fde52b5c 938
19692e8d 939 if (is_utf8) {
c445ea15 940 const char * const keysave = key;
b464bac0 941 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
cd6d36ac 942
19692e8d 943 if (is_utf8)
cd6d36ac
NC
944 k_flags |= HVhek_UTF8;
945 else
946 k_flags &= ~HVhek_UTF8;
7f66fda2
NC
947 if (key != keysave) {
948 if (k_flags & HVhek_FREEKEY) {
949 /* This shouldn't happen if our caller does what we expect,
950 but strictly the API allows it. */
951 Safefree(keysave);
952 }
953 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
954 }
cd6d36ac 955 HvHASKFLAGS_on((SV*)hv);
19692e8d 956 }
f9a63242 957
4b5190b5
NC
958 if (HvREHASH(hv)) {
959 PERL_HASH_INTERNAL(hash, key, klen);
960 } else if (!hash) {
7a9669ca 961 if (keysv && (SvIsCOW_shared_hash(keysv))) {
c158a4fd 962 hash = SvSHARED_HASH(keysv);
7a9669ca
NC
963 } else {
964 PERL_HASH(hash, key, klen);
965 }
4b5190b5 966 }
fde52b5c 967
7a9669ca
NC
968 masked_flags = (k_flags & HVhek_MASK);
969
9e720f71 970 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
fde52b5c 971 entry = *oentry;
9e720f71 972 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
6136c704 973 SV *sv;
fde52b5c
PP
974 if (HeHASH(entry) != hash) /* strings can't be equal */
975 continue;
eb160463 976 if (HeKLEN(entry) != (I32)klen)
fde52b5c 977 continue;
1c846c1f 978 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 979 continue;
7a9669ca 980 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 981 continue;
8aacddc1 982
5d2b1485
NC
983 if (hv == PL_strtab) {
984 if (k_flags & HVhek_FREEKEY)
985 Safefree(key);
986 Perl_croak(aTHX_ S_strtab_error, "delete");
987 }
988
8aacddc1 989 /* if placeholder is here, it's already been deleted.... */
6136c704
AL
990 if (HeVAL(entry) == &PL_sv_placeholder) {
991 if (k_flags & HVhek_FREEKEY)
992 Safefree(key);
993 return NULL;
8aacddc1 994 }
6136c704 995 if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
d4c19fe8 996 hv_notallowed(k_flags, key, klen,
c8cd6465
NC
997 "Attempt to delete readonly key '%"SVf"' from"
998 " a restricted hash");
8aacddc1 999 }
b84d0860
NC
1000 if (k_flags & HVhek_FREEKEY)
1001 Safefree(key);
8aacddc1 1002
cd6d36ac 1003 if (d_flags & G_DISCARD)
a0714e2c 1004 sv = NULL;
94f7643d 1005 else {
79d01fbf 1006 sv = sv_2mortal(HeVAL(entry));
7996736c 1007 HeVAL(entry) = &PL_sv_placeholder;
94f7643d 1008 }
8aacddc1
NIS
1009
1010 /*
1011 * If a restricted hash, rather than really deleting the entry, put
1012 * a placeholder there. This marks the key as being "approved", so
1013 * we can still access via not-really-existing key without raising
1014 * an error.
1015 */
1016 if (SvREADONLY(hv)) {
754604c4 1017 SvREFCNT_dec(HeVAL(entry));
7996736c 1018 HeVAL(entry) = &PL_sv_placeholder;
8aacddc1
NIS
1019 /* We'll be saving this slot, so the number of allocated keys
1020 * doesn't go down, but the number placeholders goes up */
ca732855 1021 HvPLACEHOLDERS(hv)++;
8aacddc1 1022 } else {
a26e96df 1023 *oentry = HeNEXT(entry);
9e720f71 1024 if(!*first_entry) {
a26e96df 1025 xhv->xhv_fill--; /* HvFILL(hv)-- */
9e720f71 1026 }
b79f7545 1027 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
8aacddc1
NIS
1028 HvLAZYDEL_on(hv);
1029 else
1030 hv_free_ent(hv, entry);
4c7185a0 1031 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
574c8022 1032 if (xhv->xhv_keys == 0)
19692e8d 1033 HvHASKFLAGS_off(hv);
8aacddc1 1034 }
79072805
LW
1035 return sv;
1036 }
8aacddc1 1037 if (SvREADONLY(hv)) {
d4c19fe8 1038 hv_notallowed(k_flags, key, klen,
c8cd6465
NC
1039 "Attempt to delete disallowed key '%"SVf"' from"
1040 " a restricted hash");
8aacddc1
NIS
1041 }
1042
19692e8d 1043 if (k_flags & HVhek_FREEKEY)
f9a63242 1044 Safefree(key);
a0714e2c 1045 return NULL;
79072805
LW
1046}
1047
76e3520e 1048STATIC void
cea2e8a9 1049S_hsplit(pTHX_ HV *hv)
79072805 1050{
97aff369 1051 dVAR;
1e05feb3 1052 register XPVHV* const xhv = (XPVHV*)SvANY(hv);
a3b680e6 1053 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
79072805
LW
1054 register I32 newsize = oldsize * 2;
1055 register I32 i;
7b2c381c 1056 char *a = (char*) HvARRAY(hv);
72311751 1057 register HE **aep;
79072805 1058 register HE **oentry;
4b5190b5
NC
1059 int longest_chain = 0;
1060 int was_shared;
79072805 1061
18026298 1062 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
6c9570dc 1063 (void*)hv, (int) oldsize);*/
18026298 1064
5d88ecd7 1065 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
18026298
NC
1066 /* Can make this clear any placeholders first for non-restricted hashes,
1067 even though Storable rebuilds restricted hashes by putting in all the
1068 placeholders (first) before turning on the readonly flag, because
1069 Storable always pre-splits the hash. */
1070 hv_clear_placeholders(hv);
1071 }
1072
3280af22 1073 PL_nomemok = TRUE;
8d6dde3e 1074#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
b79f7545
NC
1075 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1076 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
422a93e5 1077 if (!a) {
4a33f861 1078 PL_nomemok = FALSE;
422a93e5
GA
1079 return;
1080 }
b79f7545 1081 if (SvOOK(hv)) {
7a9b70e9 1082 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
b79f7545 1083 }
4633a7c4 1084#else
a02a5408 1085 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545 1086 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
422a93e5 1087 if (!a) {
3280af22 1088 PL_nomemok = FALSE;
422a93e5
GA
1089 return;
1090 }
7b2c381c 1091 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
b79f7545
NC
1092 if (SvOOK(hv)) {
1093 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1094 }
fba3b22e 1095 if (oldsize >= 64) {
7b2c381c 1096 offer_nice_chunk(HvARRAY(hv),
b79f7545
NC
1097 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1098 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
4633a7c4
LW
1099 }
1100 else
7b2c381c 1101 Safefree(HvARRAY(hv));
4633a7c4
LW
1102#endif
1103
3280af22 1104 PL_nomemok = FALSE;
72311751 1105 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
cbec9347 1106 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
7b2c381c 1107 HvARRAY(hv) = (HE**) a;
72311751 1108 aep = (HE**)a;
79072805 1109
72311751 1110 for (i=0; i<oldsize; i++,aep++) {
4b5190b5
NC
1111 int left_length = 0;
1112 int right_length = 0;
a3b680e6
AL
1113 register HE *entry;
1114 register HE **bep;
4b5190b5 1115
72311751 1116 if (!*aep) /* non-existent */
79072805 1117 continue;
72311751
GS
1118 bep = aep+oldsize;
1119 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
eb160463 1120 if ((HeHASH(entry) & newsize) != (U32)i) {
fde52b5c 1121 *oentry = HeNEXT(entry);
72311751
GS
1122 HeNEXT(entry) = *bep;
1123 if (!*bep)
cbec9347 1124 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1125 *bep = entry;
4b5190b5 1126 right_length++;
79072805
LW
1127 continue;
1128 }
4b5190b5 1129 else {
fde52b5c 1130 oentry = &HeNEXT(entry);
4b5190b5
NC
1131 left_length++;
1132 }
79072805 1133 }
72311751 1134 if (!*aep) /* everything moved */
cbec9347 1135 xhv->xhv_fill--; /* HvFILL(hv)-- */
4b5190b5
NC
1136 /* I think we don't actually need to keep track of the longest length,
1137 merely flag if anything is too long. But for the moment while
1138 developing this code I'll track it. */
1139 if (left_length > longest_chain)
1140 longest_chain = left_length;
1141 if (right_length > longest_chain)
1142 longest_chain = right_length;
1143 }
1144
1145
1146 /* Pick your policy for "hashing isn't working" here: */
fdcd69b6 1147 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
4b5190b5
NC
1148 || HvREHASH(hv)) {
1149 return;
79072805 1150 }
4b5190b5
NC
1151
1152 if (hv == PL_strtab) {
1153 /* Urg. Someone is doing something nasty to the string table.
1154 Can't win. */
1155 return;
1156 }
1157
1158 /* Awooga. Awooga. Pathological data. */
6c9570dc 1159 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
4b5190b5
NC
1160 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1161
1162 ++newsize;
a02a5408 1163 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545
NC
1164 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1165 if (SvOOK(hv)) {
1166 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1167 }
1168
4b5190b5
NC
1169 was_shared = HvSHAREKEYS(hv);
1170
1171 xhv->xhv_fill = 0;
1172 HvSHAREKEYS_off(hv);
1173 HvREHASH_on(hv);
1174
7b2c381c 1175 aep = HvARRAY(hv);
4b5190b5
NC
1176
1177 for (i=0; i<newsize; i++,aep++) {
a3b680e6 1178 register HE *entry = *aep;
4b5190b5
NC
1179 while (entry) {
1180 /* We're going to trash this HE's next pointer when we chain it
1181 into the new hash below, so store where we go next. */
9d4ba2ae 1182 HE * const next = HeNEXT(entry);
4b5190b5 1183 UV hash;
a3b680e6 1184 HE **bep;
4b5190b5
NC
1185
1186 /* Rehash it */
1187 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1188
1189 if (was_shared) {
1190 /* Unshare it. */
aec46f14 1191 HEK * const new_hek
4b5190b5
NC
1192 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1193 hash, HeKFLAGS(entry));
1194 unshare_hek (HeKEY_hek(entry));
1195 HeKEY_hek(entry) = new_hek;
1196 } else {
1197 /* Not shared, so simply write the new hash in. */
1198 HeHASH(entry) = hash;
1199 }
1200 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1201 HEK_REHASH_on(HeKEY_hek(entry));
1202 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1203
1204 /* Copy oentry to the correct new chain. */
1205 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1206 if (!*bep)
1207 xhv->xhv_fill++; /* HvFILL(hv)++ */
1208 HeNEXT(entry) = *bep;
1209 *bep = entry;
1210
1211 entry = next;
1212 }
1213 }
7b2c381c
NC
1214 Safefree (HvARRAY(hv));
1215 HvARRAY(hv) = (HE **)a;
79072805
LW
1216}
1217
72940dca 1218void
864dbfa3 1219Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 1220{
97aff369 1221 dVAR;
cbec9347 1222 register XPVHV* xhv = (XPVHV*)SvANY(hv);
a3b680e6 1223 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
72940dca
PP
1224 register I32 newsize;
1225 register I32 i;
72311751
GS
1226 register char *a;
1227 register HE **aep;
72940dca
PP
1228 register HE *entry;
1229 register HE **oentry;
1230
1231 newsize = (I32) newmax; /* possible truncation here */
1232 if (newsize != newmax || newmax <= oldsize)
1233 return;
1234 while ((newsize & (1 + ~newsize)) != newsize) {
1235 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1236 }
1237 if (newsize < newmax)
1238 newsize *= 2;
1239 if (newsize < newmax)
1240 return; /* overflow detection */
1241
7b2c381c 1242 a = (char *) HvARRAY(hv);
72940dca 1243 if (a) {
3280af22 1244 PL_nomemok = TRUE;
8d6dde3e 1245#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
b79f7545
NC
1246 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1247 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
8aacddc1 1248 if (!a) {
4a33f861 1249 PL_nomemok = FALSE;
422a93e5
GA
1250 return;
1251 }
b79f7545 1252 if (SvOOK(hv)) {
7a9b70e9 1253 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
b79f7545 1254 }
72940dca 1255#else
a02a5408 1256 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545 1257 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
8aacddc1 1258 if (!a) {
3280af22 1259 PL_nomemok = FALSE;
422a93e5
GA
1260 return;
1261 }
7b2c381c 1262 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
b79f7545
NC
1263 if (SvOOK(hv)) {
1264 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1265 }
fba3b22e 1266 if (oldsize >= 64) {
7b2c381c 1267 offer_nice_chunk(HvARRAY(hv),
b79f7545
NC
1268 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1269 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
72940dca
PP
1270 }
1271 else
7b2c381c 1272 Safefree(HvARRAY(hv));
72940dca 1273#endif
3280af22 1274 PL_nomemok = FALSE;
72311751 1275 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca
PP
1276 }
1277 else {
a02a5408 1278 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
72940dca 1279 }
cbec9347 1280 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
7b2c381c 1281 HvARRAY(hv) = (HE **) a;
cbec9347 1282 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
72940dca
PP
1283 return;
1284
72311751
GS
1285 aep = (HE**)a;
1286 for (i=0; i<oldsize; i++,aep++) {
1287 if (!*aep) /* non-existent */
72940dca 1288 continue;
72311751 1289 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
6136c704
AL
1290 register I32 j = (HeHASH(entry) & newsize);
1291
1292 if (j != i) {
72940dca
PP
1293 j -= i;
1294 *oentry = HeNEXT(entry);
72311751 1295 if (!(HeNEXT(entry) = aep[j]))
cbec9347 1296 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1297 aep[j] = entry;
72940dca
PP
1298 continue;
1299 }
1300 else
1301 oentry = &HeNEXT(entry);
1302 }
72311751 1303 if (!*aep) /* everything moved */
cbec9347 1304 xhv->xhv_fill--; /* HvFILL(hv)-- */
72940dca
PP
1305 }
1306}
1307
954c1994
GS
1308/*
1309=for apidoc newHV
1310
1311Creates a new HV. The reference count is set to 1.
1312
1313=cut
1314*/
1315
79072805 1316HV *
864dbfa3 1317Perl_newHV(pTHX)
79072805 1318{
cbec9347 1319 register XPVHV* xhv;
b9f83d2f 1320 HV * const hv = (HV*)newSV_type(SVt_PVHV);
cbec9347 1321 xhv = (XPVHV*)SvANY(hv);
ce5d0612 1322 assert(!SvOK(hv));
1c846c1f 1323#ifndef NODEFAULT_SHAREKEYS
fde52b5c 1324 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1c846c1f 1325#endif
4b5190b5 1326
cbec9347
JH
1327 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1328 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
79072805
LW
1329 return hv;
1330}
1331
b3ac6de7 1332HV *
864dbfa3 1333Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 1334{
9d4ba2ae 1335 HV * const hv = newHV();
4beac62f 1336 STRLEN hv_max, hv_fill;
4beac62f
AMS
1337
1338 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1339 return hv;
4beac62f 1340 hv_max = HvMAX(ohv);
b3ac6de7 1341
b56ba0bf
AMS
1342 if (!SvMAGICAL((SV *)ohv)) {
1343 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
eb160463 1344 STRLEN i;
a3b680e6 1345 const bool shared = !!HvSHAREKEYS(ohv);
aec46f14 1346 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
ff875642 1347 char *a;
a02a5408 1348 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
ff875642 1349 ents = (HE**)a;
b56ba0bf
AMS
1350
1351 /* In each bucket... */
1352 for (i = 0; i <= hv_max; i++) {
6136c704 1353 HE *prev = NULL;
aec46f14 1354 HE *oent = oents[i];
b56ba0bf
AMS
1355
1356 if (!oent) {
1357 ents[i] = NULL;
1358 continue;
1359 }
1360
1361 /* Copy the linked list of entries. */
aec46f14 1362 for (; oent; oent = HeNEXT(oent)) {
a3b680e6
AL
1363 const U32 hash = HeHASH(oent);
1364 const char * const key = HeKEY(oent);
1365 const STRLEN len = HeKLEN(oent);
1366 const int flags = HeKFLAGS(oent);
6136c704 1367 HE * const ent = new_HE();
b56ba0bf 1368
45dea987 1369 HeVAL(ent) = newSVsv(HeVAL(oent));
19692e8d 1370 HeKEY_hek(ent)
6e838c70 1371 = shared ? share_hek_flags(key, len, hash, flags)
19692e8d 1372 : save_hek_flags(key, len, hash, flags);
b56ba0bf
AMS
1373 if (prev)
1374 HeNEXT(prev) = ent;
1375 else
1376 ents[i] = ent;
1377 prev = ent;
1378 HeNEXT(ent) = NULL;
1379 }
1380 }
1381
1382 HvMAX(hv) = hv_max;
1383 HvFILL(hv) = hv_fill;
8aacddc1 1384 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
b56ba0bf 1385 HvARRAY(hv) = ents;
aec46f14 1386 } /* not magical */
b56ba0bf
AMS
1387 else {
1388 /* Iterate over ohv, copying keys and values one at a time. */
b3ac6de7 1389 HE *entry;
bfcb3514
NC
1390 const I32 riter = HvRITER_get(ohv);
1391 HE * const eiter = HvEITER_get(ohv);
b56ba0bf
AMS
1392
1393 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1394 while (hv_max && hv_max + 1 >= hv_fill * 2)
1395 hv_max = hv_max / 2;
1396 HvMAX(hv) = hv_max;
1397
4a76a316 1398 hv_iterinit(ohv);
e16e2ff8 1399 while ((entry = hv_iternext_flags(ohv, 0))) {
04fe65b0
RGS
1400 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1401 newSVsv(HeVAL(entry)), HeHASH(entry),
1402 HeKFLAGS(entry));
b3ac6de7 1403 }
bfcb3514
NC
1404 HvRITER_set(ohv, riter);
1405 HvEITER_set(ohv, eiter);
b3ac6de7 1406 }
1c846c1f 1407
b3ac6de7
IZ
1408 return hv;
1409}
1410
5b9c0671
NC
1411/* A rather specialised version of newHVhv for copying %^H, ensuring all the
1412 magic stays on it. */
1413HV *
1414Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1415{
1416 HV * const hv = newHV();
1417 STRLEN hv_fill;
1418
1419 if (ohv && (hv_fill = HvFILL(ohv))) {
1420 STRLEN hv_max = HvMAX(ohv);
1421 HE *entry;
1422 const I32 riter = HvRITER_get(ohv);
1423 HE * const eiter = HvEITER_get(ohv);
1424
1425 while (hv_max && hv_max + 1 >= hv_fill * 2)
1426 hv_max = hv_max / 2;
1427 HvMAX(hv) = hv_max;
1428
1429 hv_iterinit(ohv);
1430 while ((entry = hv_iternext_flags(ohv, 0))) {
1431 SV *const sv = newSVsv(HeVAL(entry));
1432 sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1433 (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
04fe65b0
RGS
1434 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1435 sv, HeHASH(entry), HeKFLAGS(entry));
5b9c0671
NC
1436 }
1437 HvRITER_set(ohv, riter);
1438 HvEITER_set(ohv, eiter);
1439 }
1440 hv_magic(hv, NULL, PERL_MAGIC_hints);
1441 return hv;
1442}
1443
79072805 1444void
864dbfa3 1445Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 1446{
97aff369 1447 dVAR;
16bdeea2
GS
1448 SV *val;
1449
68dc0745 1450 if (!entry)
79072805 1451 return;
16bdeea2 1452 val = HeVAL(entry);
a5a709ec 1453 if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv))
0fa56319 1454 mro_method_changed_in(hv); /* deletion of method from stash */
16bdeea2 1455 SvREFCNT_dec(val);
68dc0745
PP
1456 if (HeKLEN(entry) == HEf_SVKEY) {
1457 SvREFCNT_dec(HeKEY_sv(entry));
8aacddc1 1458 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1459 }
1460 else if (HvSHAREKEYS(hv))
68dc0745 1461 unshare_hek(HeKEY_hek(entry));
fde52b5c 1462 else
68dc0745 1463 Safefree(HeKEY_hek(entry));
d33b2eba 1464 del_HE(entry);
79072805
LW
1465}
1466
1467void
864dbfa3 1468Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 1469{
97aff369 1470 dVAR;
68dc0745 1471 if (!entry)
79072805 1472 return;
bc4947fc
NC
1473 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1474 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
68dc0745 1475 if (HeKLEN(entry) == HEf_SVKEY) {
bc4947fc 1476 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
44a8e56a 1477 }
bc4947fc 1478 hv_free_ent(hv, entry);
79072805
LW
1479}
1480
954c1994
GS
1481/*
1482=for apidoc hv_clear
1483
1484Clears a hash, making it empty.
1485
1486=cut
1487*/
1488
79072805 1489void
864dbfa3 1490Perl_hv_clear(pTHX_ HV *hv)
79072805 1491{
27da23d5 1492 dVAR;
cbec9347 1493 register XPVHV* xhv;
79072805
LW
1494 if (!hv)
1495 return;
49293501 1496
ecae49c0
NC
1497 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1498
34c3c4e3
DM
1499 xhv = (XPVHV*)SvANY(hv);
1500
7b2c381c 1501 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
34c3c4e3 1502 /* restricted hash: convert all keys to placeholders */
b464bac0
AL
1503 STRLEN i;
1504 for (i = 0; i <= xhv->xhv_max; i++) {
7b2c381c 1505 HE *entry = (HvARRAY(hv))[i];
3a676441
JH
1506 for (; entry; entry = HeNEXT(entry)) {
1507 /* not already placeholder */
7996736c 1508 if (HeVAL(entry) != &PL_sv_placeholder) {
3a676441 1509 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
6136c704 1510 SV* const keysv = hv_iterkeysv(entry);
3a676441 1511 Perl_croak(aTHX_
95b63a38
JH
1512 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1513 (void*)keysv);
3a676441
JH
1514 }
1515 SvREFCNT_dec(HeVAL(entry));
7996736c 1516 HeVAL(entry) = &PL_sv_placeholder;
ca732855 1517 HvPLACEHOLDERS(hv)++;
3a676441 1518 }
34c3c4e3
DM
1519 }
1520 }
df8c6964 1521 goto reset;
49293501
MS
1522 }
1523
463ee0b2 1524 hfreeentries(hv);
ca732855 1525 HvPLACEHOLDERS_set(hv, 0);
7b2c381c 1526 if (HvARRAY(hv))
41f62432 1527 Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
a0d0e21e
LW
1528
1529 if (SvRMAGICAL(hv))
1c846c1f 1530 mg_clear((SV*)hv);
574c8022 1531
19692e8d 1532 HvHASKFLAGS_off(hv);
bb443f97 1533 HvREHASH_off(hv);
df8c6964 1534 reset:
b79f7545 1535 if (SvOOK(hv)) {
dd69841b
BB
1536 if(HvNAME_get(hv))
1537 mro_isa_changed_in(hv);
bfcb3514
NC
1538 HvEITER_set(hv, NULL);
1539 }
79072805
LW
1540}
1541
3540d4ce
AB
1542/*
1543=for apidoc hv_clear_placeholders
1544
1545Clears any placeholders from a hash. If a restricted hash has any of its keys
1546marked as readonly and the key is subsequently deleted, the key is not actually
1547deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1548it so it will be ignored by future operations such as iterating over the hash,
4cdaeff7 1549but will still allow the hash to have a value reassigned to the key at some
3540d4ce
AB
1550future point. This function clears any such placeholder keys from the hash.
1551See Hash::Util::lock_keys() for an example of its use.
1552
1553=cut
1554*/
1555
1556void
1557Perl_hv_clear_placeholders(pTHX_ HV *hv)
1558{
27da23d5 1559 dVAR;
b3ca2e83
NC
1560 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1561
1562 if (items)
1563 clear_placeholders(hv, items);
1564}
1565
1566static void
1567S_clear_placeholders(pTHX_ HV *hv, U32 items)
1568{
1569 dVAR;
b464bac0 1570 I32 i;
d3677389
NC
1571
1572 if (items == 0)
1573 return;
1574
b464bac0 1575 i = HvMAX(hv);
d3677389
NC
1576 do {
1577 /* Loop down the linked list heads */
6136c704 1578 bool first = TRUE;
d3677389 1579 HE **oentry = &(HvARRAY(hv))[i];
cf6db12b 1580 HE *entry;
d3677389 1581
cf6db12b 1582 while ((entry = *oentry)) {
d3677389
NC
1583 if (HeVAL(entry) == &PL_sv_placeholder) {
1584 *oentry = HeNEXT(entry);
1585 if (first && !*oentry)
1586 HvFILL(hv)--; /* This linked list is now empty. */
2e58978b 1587 if (entry == HvEITER_get(hv))
d3677389
NC
1588 HvLAZYDEL_on(hv);
1589 else
1590 hv_free_ent(hv, entry);
1591
1592 if (--items == 0) {
1593 /* Finished. */
5d88ecd7 1594 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
d3677389
NC
1595 if (HvKEYS(hv) == 0)
1596 HvHASKFLAGS_off(hv);
5d88ecd7 1597 HvPLACEHOLDERS_set(hv, 0);
d3677389
NC
1598 return;
1599 }
213ce8b3
NC
1600 } else {
1601 oentry = &HeNEXT(entry);
6136c704 1602 first = FALSE;
d3677389
NC
1603 }
1604 }
1605 } while (--i >= 0);
1606 /* You can't get here, hence assertion should always fail. */
1607 assert (items == 0);
1608 assert (0);
3540d4ce
AB
1609}
1610
76e3520e 1611STATIC void
cea2e8a9 1612S_hfreeentries(pTHX_ HV *hv)
79072805 1613{
23976bdd 1614 /* This is the array that we're going to restore */
fd7de8a8 1615 HE **const orig_array = HvARRAY(hv);
23976bdd
NC
1616 HEK *name;
1617 int attempts = 100;
3abe233e 1618
fd7de8a8 1619 if (!orig_array)
79072805 1620 return;
a0d0e21e 1621
23976bdd
NC
1622 if (SvOOK(hv)) {
1623 /* If the hash is actually a symbol table with a name, look after the
1624 name. */
1625 struct xpvhv_aux *iter = HvAUX(hv);
1626
1627 name = iter->xhv_name;
1628 iter->xhv_name = NULL;
1629 } else {
1630 name = NULL;
1631 }
1632
23976bdd
NC
1633 /* orig_array remains unchanged throughout the loop. If after freeing all
1634 the entries it turns out that one of the little blighters has triggered
1635 an action that has caused HvARRAY to be re-allocated, then we set
1636 array to the new HvARRAY, and try again. */
1637
1638 while (1) {
1639 /* This is the one we're going to try to empty. First time round
1640 it's the original array. (Hopefully there will only be 1 time
1641 round) */
6136c704 1642 HE ** const array = HvARRAY(hv);
7440661e 1643 I32 i = HvMAX(hv);
23976bdd
NC
1644
1645 /* Because we have taken xhv_name out, the only allocated pointer
1646 in the aux structure that might exist is the backreference array.
1647 */
1648
1649 if (SvOOK(hv)) {
7440661e 1650 HE *entry;
e1a479c5 1651 struct mro_meta *meta;
23976bdd
NC
1652 struct xpvhv_aux *iter = HvAUX(hv);
1653 /* If there are weak references to this HV, we need to avoid
1654 freeing them up here. In particular we need to keep the AV
1655 visible as what we're deleting might well have weak references
1656 back to this HV, so the for loop below may well trigger
1657 the removal of backreferences from this array. */
1658
1659 if (iter->xhv_backreferences) {
1660 /* So donate them to regular backref magic to keep them safe.
1661 The sv_magic will increase the reference count of the AV,
1662 so we need to drop it first. */
5b285ea4 1663 SvREFCNT_dec(iter->xhv_backreferences);
23976bdd
NC
1664 if (AvFILLp(iter->xhv_backreferences) == -1) {
1665 /* Turns out that the array is empty. Just free it. */
1666 SvREFCNT_dec(iter->xhv_backreferences);
1b8791d1 1667
23976bdd
NC
1668 } else {
1669 sv_magic((SV*)hv, (SV*)iter->xhv_backreferences,
1670 PERL_MAGIC_backref, NULL, 0);
1671 }
1672 iter->xhv_backreferences = NULL;
5b285ea4 1673 }
86f55936 1674
23976bdd
NC
1675 entry = iter->xhv_eiter; /* HvEITER(hv) */
1676 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1677 HvLAZYDEL_off(hv);
1678 hv_free_ent(hv, entry);
1679 }
1680 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1681 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
b79f7545 1682
e1a479c5
BB
1683 if((meta = iter->xhv_mro_meta)) {
1684 if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
1685 if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3);
e1a479c5
BB
1686 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1687 Safefree(meta);
1688 iter->xhv_mro_meta = NULL;
1689 }
1690
23976bdd 1691 /* There are now no allocated pointers in the aux structure. */
2f86008e 1692
23976bdd
NC
1693 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
1694 /* What aux structure? */
a0d0e21e 1695 }
bfcb3514 1696
23976bdd
NC
1697 /* make everyone else think the array is empty, so that the destructors
1698 * called for freed entries can't recusively mess with us */
1699 HvARRAY(hv) = NULL;
1700 HvFILL(hv) = 0;
1701 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1702
7440661e
NC
1703
1704 do {
1705 /* Loop down the linked list heads */
1706 HE *entry = array[i];
1707
1708 while (entry) {
23976bdd
NC
1709 register HE * const oentry = entry;
1710 entry = HeNEXT(entry);
1711 hv_free_ent(hv, oentry);
1712 }
7440661e 1713 } while (--i >= 0);
b79f7545 1714
23976bdd
NC
1715 /* As there are no allocated pointers in the aux structure, it's now
1716 safe to free the array we just cleaned up, if it's not the one we're
1717 going to put back. */
1718 if (array != orig_array) {
1719 Safefree(array);
1720 }
b79f7545 1721
23976bdd
NC
1722 if (!HvARRAY(hv)) {
1723 /* Good. No-one added anything this time round. */
1724 break;
bfcb3514 1725 }
b79f7545 1726
23976bdd
NC
1727 if (SvOOK(hv)) {
1728 /* Someone attempted to iterate or set the hash name while we had
1729 the array set to 0. We'll catch backferences on the next time
1730 round the while loop. */
1731 assert(HvARRAY(hv));
1b8791d1 1732
23976bdd
NC
1733 if (HvAUX(hv)->xhv_name) {
1734 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1735 }
1736 }
1737
1738 if (--attempts == 0) {
1739 Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1740 }
6136c704 1741 }
23976bdd
NC
1742
1743 HvARRAY(hv) = orig_array;
1744
1745 /* If the hash was actually a symbol table, put the name back. */
1746 if (name) {
1747 /* We have restored the original array. If name is non-NULL, then
1748 the original array had an aux structure at the end. So this is
1749 valid: */
1750 SvFLAGS(hv) |= SVf_OOK;
1751 HvAUX(hv)->xhv_name = name;
1b8791d1 1752 }
79072805
LW
1753}
1754
954c1994
GS
1755/*
1756=for apidoc hv_undef
1757
1758Undefines the hash.
1759
1760=cut
1761*/
1762
79072805 1763void
864dbfa3 1764Perl_hv_undef(pTHX_ HV *hv)
79072805 1765{
97aff369 1766 dVAR;
cbec9347 1767 register XPVHV* xhv;
bfcb3514 1768 const char *name;
86f55936 1769
79072805
LW
1770 if (!hv)
1771 return;
ecae49c0 1772 DEBUG_A(Perl_hv_assert(aTHX_ hv));
cbec9347 1773 xhv = (XPVHV*)SvANY(hv);
dd69841b 1774
0fa56319 1775 if ((name = HvNAME_get(hv)) && !PL_dirty)
dd69841b
BB
1776 mro_isa_changed_in(hv);
1777
463ee0b2 1778 hfreeentries(hv);
dd69841b 1779 if (name) {
04fe65b0
RGS
1780 if (PL_stashcache)
1781 (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
bd61b366 1782 hv_name_set(hv, NULL, 0, 0);
85e6fe83 1783 }
b79f7545
NC
1784 SvFLAGS(hv) &= ~SVf_OOK;
1785 Safefree(HvARRAY(hv));
cbec9347 1786 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
7b2c381c 1787 HvARRAY(hv) = 0;
ca732855 1788 HvPLACEHOLDERS_set(hv, 0);
a0d0e21e
LW
1789
1790 if (SvRMAGICAL(hv))
1c846c1f 1791 mg_clear((SV*)hv);
79072805
LW
1792}
1793
b464bac0 1794static struct xpvhv_aux*
5f66b61c 1795S_hv_auxinit(HV *hv) {
bfcb3514 1796 struct xpvhv_aux *iter;
b79f7545 1797 char *array;
bfcb3514 1798
b79f7545 1799 if (!HvARRAY(hv)) {
a02a5408 1800 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
b79f7545
NC
1801 + sizeof(struct xpvhv_aux), char);
1802 } else {
1803 array = (char *) HvARRAY(hv);
1804 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1805 + sizeof(struct xpvhv_aux), char);
1806 }
1807 HvARRAY(hv) = (HE**) array;
1808 /* SvOOK_on(hv) attacks the IV flags. */
1809 SvFLAGS(hv) |= SVf_OOK;
1810 iter = HvAUX(hv);
bfcb3514
NC
1811
1812 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1813 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
bfcb3514 1814 iter->xhv_name = 0;
86f55936 1815 iter->xhv_backreferences = 0;
e1a479c5 1816 iter->xhv_mro_meta = NULL;
bfcb3514
NC
1817 return iter;
1818}
1819
954c1994
GS
1820/*
1821=for apidoc hv_iterinit
1822
1823Prepares a starting point to traverse a hash table. Returns the number of
1824keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1c846c1f 1825currently only meaningful for hashes without tie magic.
954c1994
GS
1826
1827NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1828hash buckets that happen to be in use. If you still need that esoteric
1829value, you can get it through the macro C<HvFILL(tb)>.
1830
e16e2ff8 1831
954c1994
GS
1832=cut
1833*/
1834
79072805 1835I32
864dbfa3 1836Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1837{
aa689395 1838 if (!hv)
cea2e8a9 1839 Perl_croak(aTHX_ "Bad hash");
bfcb3514 1840
b79f7545 1841 if (SvOOK(hv)) {
6136c704 1842 struct xpvhv_aux * const iter = HvAUX(hv);
0bd48802 1843 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
bfcb3514
NC
1844 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1845 HvLAZYDEL_off(hv);
1846 hv_free_ent(hv, entry);
1847 }
1848 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1849 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
bfcb3514 1850 } else {
6136c704 1851 hv_auxinit(hv);
72940dca 1852 }
44a2ac75 1853
cbec9347 1854 /* used to be xhv->xhv_fill before 5.004_65 */
5d88ecd7 1855 return HvTOTALKEYS(hv);
79072805 1856}
bfcb3514
NC
1857
1858I32 *
1859Perl_hv_riter_p(pTHX_ HV *hv) {
1860 struct xpvhv_aux *iter;
1861
1862 if (!hv)
1863 Perl_croak(aTHX_ "Bad hash");
1864
6136c704 1865 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
bfcb3514
NC
1866 return &(iter->xhv_riter);
1867}
1868
1869HE **
1870Perl_hv_eiter_p(pTHX_ HV *hv) {
1871 struct xpvhv_aux *iter;
1872
1873 if (!hv)
1874 Perl_croak(aTHX_ "Bad hash");
1875
6136c704 1876 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
bfcb3514
NC
1877 return &(iter->xhv_eiter);
1878}
1879
1880void
1881Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1882 struct xpvhv_aux *iter;
1883
1884 if (!hv)
1885 Perl_croak(aTHX_ "Bad hash");
1886
b79f7545
NC
1887 if (SvOOK(hv)) {
1888 iter = HvAUX(hv);
1889 } else {
bfcb3514
NC
1890 if (riter == -1)
1891 return;
1892
6136c704 1893 iter = hv_auxinit(hv);
bfcb3514
NC
1894 }
1895 iter->xhv_riter = riter;
1896}
1897
1898void
1899Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1900 struct xpvhv_aux *iter;
1901
1902 if (!hv)
1903 Perl_croak(aTHX_ "Bad hash");
1904
b79f7545
NC
1905 if (SvOOK(hv)) {
1906 iter = HvAUX(hv);
1907 } else {
bfcb3514
NC
1908 /* 0 is the default so don't go malloc()ing a new structure just to
1909 hold 0. */
1910 if (!eiter)
1911 return;
1912
6136c704 1913 iter = hv_auxinit(hv);
bfcb3514
NC
1914 }
1915 iter->xhv_eiter = eiter;
1916}
1917
bfcb3514 1918void
4164be69 1919Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
bfcb3514 1920{
97aff369 1921 dVAR;
b79f7545 1922 struct xpvhv_aux *iter;
7423f6db 1923 U32 hash;
46c461b5
AL
1924
1925 PERL_UNUSED_ARG(flags);
bfcb3514 1926
4164be69
NC
1927 if (len > I32_MAX)
1928 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
1929
b79f7545
NC
1930 if (SvOOK(hv)) {
1931 iter = HvAUX(hv);
7423f6db
NC
1932 if (iter->xhv_name) {
1933 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1934 }
16580ff5 1935 } else {
bfcb3514
NC
1936 if (name == 0)
1937 return;
1938
6136c704 1939 iter = hv_auxinit(hv);
bfcb3514 1940 }
7423f6db 1941 PERL_HASH(hash, name, len);
adf4e37a 1942 iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
bfcb3514
NC
1943}
1944
86f55936
NC
1945AV **
1946Perl_hv_backreferences_p(pTHX_ HV *hv) {
6136c704 1947 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
96a5add6 1948 PERL_UNUSED_CONTEXT;
86f55936
NC
1949 return &(iter->xhv_backreferences);
1950}
1951
1952void
1953Perl_hv_kill_backrefs(pTHX_ HV *hv) {
1954 AV *av;
1955
1956 if (!SvOOK(hv))
1957 return;
1958
1959 av = HvAUX(hv)->xhv_backreferences;
1960
1961 if (av) {
1962 HvAUX(hv)->xhv_backreferences = 0;
1963 Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av);
1964 }
1965}
1966
954c1994 1967/*
7a7b9979
NC
1968hv_iternext is implemented as a macro in hv.h
1969
954c1994
GS
1970=for apidoc hv_iternext
1971
1972Returns entries from a hash iterator. See C<hv_iterinit>.
1973
fe7bca90
NC
1974You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1975iterator currently points to, without losing your place or invalidating your
1976iterator. Note that in this case the current entry is deleted from the hash
1977with your iterator holding the last reference to it. Your iterator is flagged
1978to free the entry on the next call to C<hv_iternext>, so you must not discard
1979your iterator immediately else the entry will leak - call C<hv_iternext> to
1980trigger the resource deallocation.
1981
fe7bca90
NC
1982=for apidoc hv_iternext_flags
1983
1984Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1985The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1986set the placeholders keys (for restricted hashes) will be returned in addition
1987to normal keys. By default placeholders are automatically skipped over.
7996736c
MHM
1988Currently a placeholder is implemented with a value that is
1989C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
fe7bca90
NC
1990restricted hashes may change, and the implementation currently is
1991insufficiently abstracted for any change to be tidy.
e16e2ff8 1992
fe7bca90 1993=cut
e16e2ff8
NC
1994*/
1995
1996HE *
1997Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1998{
27da23d5 1999 dVAR;
cbec9347 2000 register XPVHV* xhv;
79072805 2001 register HE *entry;
a0d0e21e 2002 HE *oldentry;
463ee0b2 2003 MAGIC* mg;
bfcb3514 2004 struct xpvhv_aux *iter;
79072805
LW
2005
2006 if (!hv)
cea2e8a9 2007 Perl_croak(aTHX_ "Bad hash");
81714fb9 2008
cbec9347 2009 xhv = (XPVHV*)SvANY(hv);
bfcb3514 2010
b79f7545 2011 if (!SvOOK(hv)) {
bfcb3514
NC
2012 /* Too many things (well, pp_each at least) merrily assume that you can
2013 call iv_iternext without calling hv_iterinit, so we'll have to deal
2014 with it. */
2015 hv_iterinit(hv);
bfcb3514 2016 }
b79f7545 2017 iter = HvAUX(hv);
bfcb3514
NC
2018
2019 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
e62cc96a 2020 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
44a2ac75 2021 if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
e62cc96a
YO
2022 SV * const key = sv_newmortal();
2023 if (entry) {
2024 sv_setsv(key, HeSVKEY_force(entry));
2025 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2026 }
2027 else {
2028 char *k;
2029 HEK *hek;
2030
2031 /* one HE per MAGICAL hash */
2032 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2033 Zero(entry, 1, HE);
2034 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2035 hek = (HEK*)k;
2036 HeKEY_hek(entry) = hek;
2037 HeKLEN(entry) = HEf_SVKEY;
2038 }
2039 magic_nextpack((SV*) hv,mg,key);
2040 if (SvOK(key)) {
2041 /* force key to stay around until next time */
2042 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2043 return entry; /* beware, hent_val is not set */
2044 }
2045 if (HeVAL(entry))
2046 SvREFCNT_dec(HeVAL(entry));
2047 Safefree(HeKEY_hek(entry));
2048 del_HE(entry);
2049 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2050 return NULL;
81714fb9 2051 }
79072805 2052 }
7ee146b1 2053#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
03026e68 2054 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
f675dbe5 2055 prime_env_iter();
03026e68
JM
2056#ifdef VMS
2057 /* The prime_env_iter() on VMS just loaded up new hash values
2058 * so the iteration count needs to be reset back to the beginning
2059 */
2060 hv_iterinit(hv);
2061 iter = HvAUX(hv);
2062 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2063#endif
2064 }
f675dbe5 2065#endif
463ee0b2 2066
b79f7545
NC
2067 /* hv_iterint now ensures this. */
2068 assert (HvARRAY(hv));
2069
015a5f36 2070 /* At start of hash, entry is NULL. */
fde52b5c 2071 if (entry)
8aacddc1 2072 {
fde52b5c 2073 entry = HeNEXT(entry);
e16e2ff8
NC
2074 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2075 /*
2076 * Skip past any placeholders -- don't want to include them in
2077 * any iteration.
2078 */
7996736c 2079 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
e16e2ff8
NC
2080 entry = HeNEXT(entry);
2081 }
8aacddc1
NIS
2082 }
2083 }
fde52b5c 2084 while (!entry) {
015a5f36
NC
2085 /* OK. Come to the end of the current list. Grab the next one. */
2086
bfcb3514
NC
2087 iter->xhv_riter++; /* HvRITER(hv)++ */
2088 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
015a5f36 2089 /* There is no next one. End of the hash. */
bfcb3514 2090 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
fde52b5c 2091 break;
79072805 2092 }
7b2c381c 2093 entry = (HvARRAY(hv))[iter->xhv_riter];
8aacddc1 2094
e16e2ff8 2095 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
015a5f36
NC
2096 /* If we have an entry, but it's a placeholder, don't count it.
2097 Try the next. */
7996736c 2098 while (entry && HeVAL(entry) == &PL_sv_placeholder)
015a5f36
NC
2099 entry = HeNEXT(entry);
2100 }
2101 /* Will loop again if this linked list starts NULL
2102 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2103 or if we run through it and find only placeholders. */
fde52b5c 2104 }
79072805 2105
72940dca
PP
2106 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2107 HvLAZYDEL_off(hv);
68dc0745 2108 hv_free_ent(hv, oldentry);
72940dca 2109 }
a0d0e21e 2110
fdcd69b6 2111 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
6c9570dc 2112 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
fdcd69b6 2113
bfcb3514 2114 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
79072805
LW
2115 return entry;
2116}
2117
954c1994
GS
2118/*
2119=for apidoc hv_iterkey
2120
2121Returns the key from the current position of the hash iterator. See
2122C<hv_iterinit>.
2123
2124=cut
2125*/
2126
79072805 2127char *
864dbfa3 2128Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 2129{
fde52b5c 2130 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a 2131 STRLEN len;
0bd48802 2132 char * const p = SvPV(HeKEY_sv(entry), len);
fb73857a
PP
2133 *retlen = len;
2134 return p;
fde52b5c
PP
2135 }
2136 else {
2137 *retlen = HeKLEN(entry);
2138 return HeKEY(entry);
2139 }
2140}
2141
2142/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994
GS
2143/*
2144=for apidoc hv_iterkeysv
2145
2146Returns the key as an C<SV*> from the current position of the hash
2147iterator. The return value will always be a mortal copy of the key. Also
2148see C<hv_iterinit>.
2149
2150=cut
2151*/
2152
fde52b5c 2153SV *
864dbfa3 2154Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 2155{
c1b02ed8 2156 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
79072805
LW
2157}
2158
954c1994
GS
2159/*
2160=for apidoc hv_iterval
2161
2162Returns the value from the current position of the hash iterator. See
2163C<hv_iterkey>.
2164
2165=cut
2166*/
2167
79072805 2168SV *
864dbfa3 2169Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 2170{
8990e307 2171 if (SvRMAGICAL(hv)) {
14befaf4 2172 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
c4420975 2173 SV* const sv = sv_newmortal();
bbce6d69
PP
2174 if (HeKLEN(entry) == HEf_SVKEY)
2175 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
a3b680e6
AL
2176 else
2177 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2
LW
2178 return sv;
2179 }
79072805 2180 }
fde52b5c 2181 return HeVAL(entry);
79072805
LW
2182}
2183
954c1994
GS
2184/*
2185=for apidoc hv_iternextsv
2186
2187Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2188operation.
2189
2190=cut
2191*/
2192
a0d0e21e 2193SV *
864dbfa3 2194Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e 2195{
0bd48802
AL
2196 HE * const he = hv_iternext_flags(hv, 0);
2197
2198 if (!he)
a0d0e21e
LW
2199 return NULL;
2200 *key = hv_iterkey(he, retlen);
2201 return hv_iterval(hv, he);
2202}
2203
954c1994 2204/*
bc5cdc23
NC
2205
2206Now a macro in hv.h
2207
954c1994
GS
2208=for apidoc hv_magic
2209
2210Adds magic to a hash. See C<sv_magic>.
2211
2212=cut
2213*/
2214
bbce6d69 2215/* possibly free a shared string if no one has access to it
fde52b5c
PP
2216 * len and hash must both be valid for str.
2217 */
bbce6d69 2218void
864dbfa3 2219Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 2220{
19692e8d
NC
2221 unshare_hek_or_pvn (NULL, str, len, hash);
2222}
2223
2224
2225void
2226Perl_unshare_hek(pTHX_ HEK *hek)
2227{
bf11fd37 2228 assert(hek);
19692e8d
NC
2229 unshare_hek_or_pvn(hek, NULL, 0, 0);
2230}
2231
2232/* possibly free a shared string if no one has access to it
2233 hek if non-NULL takes priority over the other 3, else str, len and hash
2234 are used. If so, len and hash must both be valid for str.
2235 */
df132699 2236STATIC void
97ddebaf 2237S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
19692e8d 2238{
97aff369 2239 dVAR;
cbec9347 2240 register XPVHV* xhv;
20454177 2241 HE *entry;
fde52b5c 2242 register HE **oentry;
45d1cc86 2243 HE **first;
c3654f1a 2244 bool is_utf8 = FALSE;
19692e8d 2245 int k_flags = 0;
aec46f14 2246 const char * const save = str;
cbbf8932 2247 struct shared_he *he = NULL;
c3654f1a 2248
19692e8d 2249 if (hek) {
cbae3960
NC
2250 /* Find the shared he which is just before us in memory. */
2251 he = (struct shared_he *)(((char *)hek)
2252 - STRUCT_OFFSET(struct shared_he,
2253 shared_he_hek));
2254
2255 /* Assert that the caller passed us a genuine (or at least consistent)
2256 shared hek */
2257 assert (he->shared_he_he.hent_hek == hek);
29404ae0
NC
2258
2259 LOCK_STRTAB_MUTEX;
de616631
NC
2260 if (he->shared_he_he.he_valu.hent_refcount - 1) {
2261 --he->shared_he_he.he_valu.hent_refcount;
29404ae0
NC
2262 UNLOCK_STRTAB_MUTEX;
2263 return;
2264 }
2265 UNLOCK_STRTAB_MUTEX;
2266
19692e8d
NC
2267 hash = HEK_HASH(hek);
2268 } else if (len < 0) {
2269 STRLEN tmplen = -len;
2270 is_utf8 = TRUE;
2271 /* See the note in hv_fetch(). --jhi */
2272 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2273 len = tmplen;
2274 if (is_utf8)
2275 k_flags = HVhek_UTF8;
2276 if (str != save)
2277 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
c3654f1a 2278 }
1c846c1f 2279
de616631 2280 /* what follows was the moral equivalent of:
6b88bc9c 2281 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
a0714e2c 2282 if (--*Svp == NULL)
6b88bc9c 2283 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 2284 } */
cbec9347 2285 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2286 /* assert(xhv_array != 0) */
5f08fbcd 2287 LOCK_STRTAB_MUTEX;
45d1cc86 2288 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
6c1b96a1
NC
2289 if (he) {
2290 const HE *const he_he = &(he->shared_he_he);
45d1cc86 2291 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
35ab5632
NC
2292 if (entry == he_he)
2293 break;
19692e8d
NC
2294 }
2295 } else {
35a4481c 2296 const int flags_masked = k_flags & HVhek_MASK;
45d1cc86 2297 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
19692e8d
NC
2298 if (HeHASH(entry) != hash) /* strings can't be equal */
2299 continue;
2300 if (HeKLEN(entry) != len)
2301 continue;
2302 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2303 continue;
2304 if (HeKFLAGS(entry) != flags_masked)
2305 continue;
19692e8d
NC
2306 break;
2307 }
2308 }
2309
35ab5632
NC
2310 if (entry) {
2311 if (--entry->he_valu.hent_refcount == 0) {
19692e8d 2312 *oentry = HeNEXT(entry);
45d1cc86
NC
2313 if (!*first) {
2314 /* There are now no entries in our slot. */
19692e8d 2315 xhv->xhv_fill--; /* HvFILL(hv)-- */
45d1cc86 2316 }
cbae3960 2317 Safefree(entry);
4c7185a0 2318 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
19692e8d 2319 }
fde52b5c 2320 }
19692e8d 2321
333f433b 2322 UNLOCK_STRTAB_MUTEX;
35ab5632 2323 if (!entry && ckWARN_d(WARN_INTERNAL))
19692e8d 2324 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB
2325 "Attempt to free non-existent shared string '%s'%s"
2326 pTHX__FORMAT,
19692e8d 2327 hek ? HEK_KEY(hek) : str,
472d47bc 2328 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
19692e8d
NC
2329 if (k_flags & HVhek_FREEKEY)
2330 Safefree(str);
fde52b5c
PP
2331}
2332
bbce6d69
PP
2333/* get a (constant) string ptr from the global string table
2334 * string will get added if it is not already there.
fde52b5c
PP
2335 * len and hash must both be valid for str.
2336 */
bbce6d69 2337HEK *
864dbfa3 2338Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 2339{
da58a35d 2340 bool is_utf8 = FALSE;
19692e8d 2341 int flags = 0;
aec46f14 2342 const char * const save = str;
da58a35d
JH
2343
2344 if (len < 0) {
77caf834 2345 STRLEN tmplen = -len;
da58a35d 2346 is_utf8 = TRUE;
77caf834
JH
2347 /* See the note in hv_fetch(). --jhi */
2348 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2349 len = tmplen;
19692e8d
NC
2350 /* If we were able to downgrade here, then than means that we were passed
2351 in a key which only had chars 0-255, but was utf8 encoded. */
2352 if (is_utf8)
2353 flags = HVhek_UTF8;
2354 /* If we found we were able to downgrade the string to bytes, then
2355 we should flag that it needs upgrading on keys or each. Also flag
2356 that we need share_hek_flags to free the string. */
2357 if (str != save)
2358 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2359 }
2360
6e838c70 2361 return share_hek_flags (str, len, hash, flags);
19692e8d
NC
2362}
2363
6e838c70 2364STATIC HEK *
19692e8d
NC
2365S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2366{
97aff369 2367 dVAR;
19692e8d 2368 register HE *entry;
35a4481c 2369 const int flags_masked = flags & HVhek_MASK;
263cb4a6 2370 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
bbce6d69 2371
fde52b5c 2372 /* what follows is the moral equivalent of:
1c846c1f 2373
6b88bc9c 2374 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
a0714e2c 2375 hv_store(PL_strtab, str, len, NULL, hash);
fdcd69b6
NC
2376
2377 Can't rehash the shared string table, so not sure if it's worth
2378 counting the number of entries in the linked list
bbce6d69 2379 */
1b6737cc 2380 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2381 /* assert(xhv_array != 0) */
5f08fbcd 2382 LOCK_STRTAB_MUTEX;
263cb4a6
NC
2383 entry = (HvARRAY(PL_strtab))[hindex];
2384 for (;entry; entry = HeNEXT(entry)) {
fde52b5c
PP
2385 if (HeHASH(entry) != hash) /* strings can't be equal */
2386 continue;
2387 if (HeKLEN(entry) != len)
2388 continue;
1c846c1f 2389 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 2390 continue;
19692e8d 2391 if (HeKFLAGS(entry) != flags_masked)
c3654f1a 2392 continue;
fde52b5c
PP
2393 break;
2394 }
263cb4a6
NC
2395
2396 if (!entry) {
45d1cc86
NC
2397 /* What used to be head of the list.
2398 If this is NULL, then we're the first entry for this slot, which
2399 means we need to increate fill. */
cbae3960
NC
2400 struct shared_he *new_entry;
2401 HEK *hek;
2402 char *k;
263cb4a6
NC
2403 HE **const head = &HvARRAY(PL_strtab)[hindex];
2404 HE *const next = *head;
cbae3960
NC
2405
2406 /* We don't actually store a HE from the arena and a regular HEK.
2407 Instead we allocate one chunk of memory big enough for both,
2408 and put the HEK straight after the HE. This way we can find the
2409 HEK directly from the HE.
2410 */
2411
a02a5408 2412 Newx(k, STRUCT_OFFSET(struct shared_he,
cbae3960
NC
2413 shared_he_hek.hek_key[0]) + len + 2, char);
2414 new_entry = (struct shared_he *)k;
2415 entry = &(new_entry->shared_he_he);
2416 hek = &(new_entry->shared_he_hek);
2417
2418 Copy(str, HEK_KEY(hek), len, char);
2419 HEK_KEY(hek)[len] = 0;
2420 HEK_LEN(hek) = len;
2421 HEK_HASH(hek) = hash;
2422 HEK_FLAGS(hek) = (unsigned char)flags_masked;
2423
2424 /* Still "point" to the HEK, so that other code need not know what
2425 we're up to. */
2426 HeKEY_hek(entry) = hek;
de616631 2427 entry->he_valu.hent_refcount = 0;
263cb4a6
NC
2428 HeNEXT(entry) = next;
2429 *head = entry;
cbae3960 2430
4c7185a0 2431 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
263cb4a6 2432 if (!next) { /* initial entry? */
cbec9347 2433 xhv->xhv_fill++; /* HvFILL(hv)++ */
4c9cc595 2434 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
cbec9347 2435 hsplit(PL_strtab);
bbce6d69
PP
2436 }
2437 }
2438
de616631 2439 ++entry->he_valu.hent_refcount;
5f08fbcd 2440 UNLOCK_STRTAB_MUTEX;
19692e8d
NC
2441
2442 if (flags & HVhek_FREEKEY)
f9a63242 2443 Safefree(str);
19692e8d 2444
6e838c70 2445 return HeKEY_hek(entry);
fde52b5c 2446}
ecae49c0 2447
ca732855
NC
2448I32 *
2449Perl_hv_placeholders_p(pTHX_ HV *hv)
2450{
2451 dVAR;
2452 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2453
2454 if (!mg) {
2455 mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2456
2457 if (!mg) {
2458 Perl_die(aTHX_ "panic: hv_placeholders_p");
2459 }
2460 }
2461 return &(mg->mg_len);
2462}
2463
2464
2465I32
2466Perl_hv_placeholders_get(pTHX_ HV *hv)
2467{
2468 dVAR;
b464bac0 2469 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
ca732855
NC
2470
2471 return mg ? mg->mg_len : 0;
2472}
2473
2474void
ac1e784a 2475Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
ca732855
NC
2476{
2477 dVAR;
b464bac0 2478 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
ca732855
NC
2479
2480 if (mg) {
2481 mg->mg_len = ph;
2482 } else if (ph) {
2483 if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2484 Perl_die(aTHX_ "panic: hv_placeholders_set");
2485 }
2486 /* else we don't need to add magic to record 0 placeholders. */
2487}
ecae49c0 2488
2a49f0f5 2489STATIC SV *
7b0bddfa
NC
2490S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2491{
0b2d3faa 2492 dVAR;
7b0bddfa
NC
2493 SV *value;
2494 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2495 case HVrhek_undef:
2496 value = newSV(0);
2497 break;
2498 case HVrhek_delete:
2499 value = &PL_sv_placeholder;
2500 break;
2501 case HVrhek_IV:
44ebaf21
NC
2502 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2503 break;
2504 case HVrhek_UV:
2505 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
7b0bddfa
NC
2506 break;
2507 case HVrhek_PV:
44ebaf21 2508 case HVrhek_PV_UTF8:
7b0bddfa
NC
2509 /* Create a string SV that directly points to the bytes in our
2510 structure. */
b9f83d2f 2511 value = newSV_type(SVt_PV);
7b0bddfa
NC
2512 SvPV_set(value, (char *) he->refcounted_he_data + 1);
2513 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2514 /* This stops anything trying to free it */
2515 SvLEN_set(value, 0);
2516 SvPOK_on(value);
2517 SvREADONLY_on(value);
44ebaf21 2518 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
7b0bddfa
NC
2519 SvUTF8_on(value);
2520 break;
2521 default:
2522 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2523 he->refcounted_he_data[0]);
2524 }
2525 return value;
2526}
2527
ecae49c0 2528/*
b3ca2e83
NC
2529=for apidoc refcounted_he_chain_2hv
2530
abc25d8c 2531Generates and returns a C<HV *> by walking up the tree starting at the passed
b3ca2e83
NC
2532in C<struct refcounted_he *>.
2533
2534=cut
2535*/
2536HV *
2537Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2538{
7a89be66 2539 dVAR;
b3ca2e83
NC
2540 HV *hv = newHV();
2541 U32 placeholders = 0;
2542 /* We could chase the chain once to get an idea of the number of keys,
2543 and call ksplit. But for now we'll make a potentially inefficient
2544 hash with only 8 entries in its array. */
2545 const U32 max = HvMAX(hv);
2546
2547 if (!HvARRAY(hv)) {
2548 char *array;
2549 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2550 HvARRAY(hv) = (HE**)array;
2551 }
2552
2553 while (chain) {
cbb1fbea 2554#ifdef USE_ITHREADS
b6bbf3fa 2555 U32 hash = chain->refcounted_he_hash;
cbb1fbea
NC
2556#else
2557 U32 hash = HEK_HASH(chain->refcounted_he_hek);
2558#endif
b3ca2e83
NC
2559 HE **oentry = &((HvARRAY(hv))[hash & max]);
2560 HE *entry = *oentry;
b6bbf3fa 2561 SV *value;
cbb1fbea 2562
b3ca2e83
NC
2563 for (; entry; entry = HeNEXT(entry)) {
2564 if (HeHASH(entry) == hash) {
9f769845
NC
2565 /* We might have a duplicate key here. If so, entry is older
2566 than the key we've already put in the hash, so if they are
2567 the same, skip adding entry. */
2568#ifdef USE_ITHREADS
2569 const STRLEN klen = HeKLEN(entry);
2570 const char *const key = HeKEY(entry);
2571 if (klen == chain->refcounted_he_keylen
2572 && (!!HeKUTF8(entry)
2573 == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2574 && memEQ(key, REF_HE_KEY(chain), klen))
2575 goto next_please;
2576#else
2577 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2578 goto next_please;
2579 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2580 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2581 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2582 HeKLEN(entry)))
2583 goto next_please;
2584#endif
b3ca2e83
NC
2585 }
2586 }
2587 assert (!entry);
2588 entry = new_HE();
2589
cbb1fbea
NC
2590#ifdef USE_ITHREADS
2591 HeKEY_hek(entry)
7b0bddfa 2592 = share_hek_flags(REF_HE_KEY(chain),
b6bbf3fa
NC
2593 chain->refcounted_he_keylen,
2594 chain->refcounted_he_hash,
2595 (chain->refcounted_he_data[0]
2596 & (HVhek_UTF8|HVhek_WASUTF8)));
cbb1fbea 2597#else
71ad1b0c 2598 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
cbb1fbea 2599#endif
7b0bddfa
NC
2600 value = refcounted_he_value(chain);
2601 if (value == &PL_sv_placeholder)
b3ca2e83 2602 placeholders++;
b6bbf3fa 2603 HeVAL(entry) = value;
b3ca2e83
NC
2604
2605 /* Link it into the chain. */
2606 HeNEXT(entry) = *oentry;
2607 if (!HeNEXT(entry)) {
2608 /* initial entry. */
2609 HvFILL(hv)++;
2610 }
2611 *oentry = entry;
2612
2613 HvTOTALKEYS(hv)++;
2614
2615 next_please:
71ad1b0c 2616 chain = chain->refcounted_he_next;
b3ca2e83
NC
2617 }
2618
2619 if (placeholders) {
2620 clear_placeholders(hv, placeholders);
2621 HvTOTALKEYS(hv) -= placeholders;
2622 }
2623
2624 /* We could check in the loop to see if we encounter any keys with key
2625 flags, but it's probably not worth it, as this per-hash flag is only
2626 really meant as an optimisation for things like Storable. */
2627 HvHASKFLAGS_on(hv);
def9038f 2628 DEBUG_A(Perl_hv_assert(aTHX_ hv));
b3ca2e83
NC
2629
2630 return hv;
2631}
2632
7b0bddfa
NC
2633SV *
2634Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2635 const char *key, STRLEN klen, int flags, U32 hash)
2636{
0b2d3faa 2637 dVAR;
7b0bddfa
NC
2638 /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2639 of your key has to exactly match that which is stored. */
2640 SV *value = &PL_sv_placeholder;
d8c5b3c5 2641 bool is_utf8;
7b0bddfa
NC
2642
2643 if (keysv) {
2644 if (flags & HVhek_FREEKEY)
2645 Safefree(key);
2646 key = SvPV_const(keysv, klen);
2647 flags = 0;
d8c5b3c5
NC
2648 is_utf8 = (SvUTF8(keysv) != 0);
2649 } else {
2650 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
7b0bddfa
NC
2651 }
2652
2653 if (!hash) {
2654 if (keysv && (SvIsCOW_shared_hash(keysv))) {
2655 hash = SvSHARED_HASH(keysv);
2656 } else {
2657 PERL_HASH(hash, key, klen);
2658 }
2659 }
2660
2661 for (; chain; chain = chain->refcounted_he_next) {
2662#ifdef USE_ITHREADS
2663 if (hash != chain->refcounted_he_hash)
2664 continue;
2665 if (klen != chain->refcounted_he_keylen)
2666 continue;
2667 if (memNE(REF_HE_KEY(chain),key,klen))
2668 continue;
d8c5b3c5
NC
2669 if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2670 continue;
7b0bddfa
NC
2671#else
2672 if (hash != HEK_HASH(chain->refcounted_he_hek))
2673 continue;
670f1322 2674 if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
7b0bddfa
NC
2675 continue;
2676 if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2677 continue;
d8c5b3c5
NC
2678 if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2679 continue;
7b0bddfa
NC
2680#endif
2681
2682 value = sv_2mortal(refcounted_he_value(chain));
2683 break;
2684 }
2685
2686 if (flags & HVhek_FREEKEY)
2687 Safefree(key);
2688
2689 return value;
2690}
2691
b3ca2e83
NC
2692/*
2693=for apidoc refcounted_he_new
2694
ec2a1de7
NC
2695Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2696stored in a compact form, all references remain the property of the caller.
2697The C<struct refcounted_he> is returned with a reference count of 1.
b3ca2e83
NC
2698
2699=cut
2700*/
2701
2702struct refcounted_he *
2703Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2704 SV *const key, SV *const value) {
7a89be66 2705 dVAR;
b3ca2e83 2706 struct refcounted_he *he;
b6bbf3fa
NC
2707 STRLEN key_len;
2708 const char *key_p = SvPV_const(key, key_len);
2709 STRLEN value_len = 0;
95b63a38 2710 const char *value_p = NULL;
b6bbf3fa
NC
2711 char value_type;
2712 char flags;
2713 STRLEN key_offset;
b3ca2e83 2714 U32 hash;
d8c5b3c5 2715 bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
b6bbf3fa
NC
2716
2717 if (SvPOK(value)) {
2718 value_type = HVrhek_PV;
2719 } else if (SvIOK(value)) {
2720 value_type = HVrhek_IV;
2721 } else if (value == &PL_sv_placeholder) {
2722 value_type = HVrhek_delete;
2723 } else if (!SvOK(value)) {
2724 value_type = HVrhek_undef;
2725 } else {
2726 value_type = HVrhek_PV;
2727 }
b3ca2e83 2728
b6bbf3fa
NC
2729 if (value_type == HVrhek_PV) {
2730 value_p = SvPV_const(value, value_len);
2731 key_offset = value_len + 2;
2732 } else {
2733 value_len = 0;
2734 key_offset = 1;
2735 }
b6bbf3fa 2736
b6bbf3fa 2737#ifdef USE_ITHREADS
10edeb5d
JH
2738 he = (struct refcounted_he*)
2739 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2740 + key_len
2741 + key_offset);
6cef672b 2742#else
10edeb5d
JH
2743 he = (struct refcounted_he*)
2744 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2745 + key_offset);
6cef672b 2746#endif
b3ca2e83 2747
b3ca2e83 2748
71ad1b0c 2749 he->refcounted_he_next = parent;
b6bbf3fa
NC
2750
2751 if (value_type == HVrhek_PV) {
2752 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
2753 he->refcounted_he_val.refcounted_he_u_len = value_len;
44ebaf21
NC
2754 /* Do it this way so that the SvUTF8() test is after the SvPV, in case
2755 the value is overloaded, and doesn't yet have the UTF-8flag set. */
2756 if (SvUTF8(value))
2757 value_type = HVrhek_PV_UTF8;
b6bbf3fa
NC
2758 } else if (value_type == HVrhek_IV) {
2759 if (SvUOK(value)) {
2760 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
44ebaf21 2761 value_type = HVrhek_UV;
b6bbf3fa
NC
2762 } else {
2763 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
2764 }
2765 }
44ebaf21 2766 flags = value_type;
b6bbf3fa
NC
2767
2768 if (is_utf8) {
2769 /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2770 As we're going to be building hash keys from this value in future,
2771 normalise it now. */
2772 key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2773 flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2774 }
2775 PERL_HASH(hash, key_p, key_len);
2776
cbb1fbea 2777#ifdef USE_ITHREADS
b6bbf3fa
NC
2778 he->refcounted_he_hash = hash;
2779 he->refcounted_he_keylen = key_len;
2780 Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
cbb1fbea 2781#else
b6bbf3fa 2782 he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
cbb1fbea 2783#endif
b6bbf3fa
NC
2784
2785 if (flags & HVhek_WASUTF8) {
2786 /* If it was downgraded from UTF-8, then the pointer returned from
2787 bytes_from_utf8 is an allocated pointer that we must free. */
2788 Safefree(key_p);
2789 }
2790
2791 he->refcounted_he_data[0] = flags;
b3ca2e83
NC
2792 he->refcounted_he_refcnt = 1;
2793
2794 return he;
2795}
2796
2797/*
2798=for apidoc refcounted_he_free
2799
2800Decrements the reference count of the passed in C<struct refcounted_he *>
2801by one. If the reference count reaches zero the structure's memory is freed,
2802and C<refcounted_he_free> iterates onto the parent node.
2803
2804=cut
2805*/
2806
2807void
2808Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
53d44271 2809 dVAR;
57ca3b03
AL
2810 PERL_UNUSED_CONTEXT;
2811
b3ca2e83
NC
2812 while (he) {
2813 struct refcounted_he *copy;
cbb1fbea 2814 U32 new_count;
b3ca2e83 2815
cbb1fbea
NC
2816 HINTS_REFCNT_LOCK;
2817 new_count = --he->refcounted_he_refcnt;
2818 HINTS_REFCNT_UNLOCK;
2819
2820 if (new_count) {
b3ca2e83 2821 return;
cbb1fbea 2822 }
b3ca2e83 2823
b6bbf3fa 2824#ifndef USE_ITHREADS
71ad1b0c 2825 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
cbb1fbea 2826#endif
b3ca2e83 2827 copy = he;
71ad1b0c 2828 he = he->refcounted_he_next;
b6bbf3fa 2829 PerlMemShared_free(copy);
b3ca2e83
NC
2830 }
2831}
2832
b3ca2e83 2833/*
ecae49c0
NC
2834=for apidoc hv_assert
2835
2836Check that a hash is in an internally consistent state.
2837
2838=cut
2839*/
2840
943795c2
NC
2841#ifdef DEBUGGING
2842
ecae49c0
NC
2843void
2844Perl_hv_assert(pTHX_ HV *hv)
2845{
57ca3b03
AL
2846 dVAR;
2847 HE* entry;
2848 int withflags = 0;
2849 int placeholders = 0;
2850 int real = 0;
2851 int bad = 0;
2852 const I32 riter = HvRITER_get(hv);
2853 HE *eiter = HvEITER_get(hv);
2854
2855 (void)hv_iterinit(hv);
2856
2857 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2858 /* sanity check the values */
2859 if (HeVAL(entry) == &PL_sv_placeholder)
2860 placeholders++;
2861 else
2862 real++;
2863 /* sanity check the keys */
2864 if (HeSVKEY(entry)) {
6f207bd3 2865 NOOP; /* Don't know what to check on SV keys. */
57ca3b03
AL
2866 } else if (HeKUTF8(entry)) {
2867 withflags++;
2868 if (HeKWASUTF8(entry)) {
2869 PerlIO_printf(Perl_debug_log,
d2a455e7 2870 "hash key has both WASUTF8 and UTF8: '%.*s'\n",
57ca3b03
AL
2871 (int) HeKLEN(entry), HeKEY(entry));
2872 bad = 1;
2873 }
2874 } else if (HeKWASUTF8(entry))
2875 withflags++;
2876 }
2877 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2878 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
2879 const int nhashkeys = HvUSEDKEYS(hv);
2880 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
2881
2882 if (nhashkeys != real) {
2883 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
2884 bad = 1;
2885 }
2886 if (nhashplaceholders != placeholders) {
2887 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
2888 bad = 1;
2889 }
2890 }
2891 if (withflags && ! HvHASKFLAGS(hv)) {
2892 PerlIO_printf(Perl_debug_log,
2893 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2894 withflags);
2895 bad = 1;
2896 }
2897 if (bad) {
2898 sv_dump((SV *)hv);
2899 }
2900 HvRITER_set(hv, riter); /* Restore hash iterator state */
2901 HvEITER_set(hv, eiter);
ecae49c0 2902}
af3babe4 2903
943795c2
NC
2904#endif
2905
af3babe4
NC
2906/*
2907 * Local variables:
2908 * c-indentation-style: bsd
2909 * c-basic-offset: 4
2910 * indent-tabs-mode: t
2911 * End:
2912 *
37442d52
RGS
2913 * ex: set ts=8 sts=4 sw=4 noet:
2914 */