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