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