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