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