This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[perl5.git] / hv.c
CommitLineData
a0d0e21e 1/* hv.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, Larry Wall
79072805
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW
8 */
9
10/*
11 * "I sit beside the fire and think of all that I have seen." --Bilbo
79072805
LW
12 */
13
14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_HV_C
79072805
LW
16#include "perl.h"
17
76e3520e 18STATIC HE*
cea2e8a9 19S_new_he(pTHX)
4633a7c4
LW
20{
21 HE* he;
333f433b
DG
22 LOCK_SV_MUTEX;
23 if (!PL_he_root)
24 more_he();
25 he = PL_he_root;
26 PL_he_root = HeNEXT(he);
27 UNLOCK_SV_MUTEX;
28 return he;
4633a7c4
LW
29}
30
76e3520e 31STATIC void
cea2e8a9 32S_del_he(pTHX_ HE *p)
4633a7c4 33{
333f433b 34 LOCK_SV_MUTEX;
3280af22
NIS
35 HeNEXT(p) = (HE*)PL_he_root;
36 PL_he_root = p;
333f433b 37 UNLOCK_SV_MUTEX;
4633a7c4
LW
38}
39
333f433b 40STATIC void
cea2e8a9 41S_more_he(pTHX)
4633a7c4
LW
42{
43 register HE* he;
44 register HE* heend;
612f20c3
GS
45 XPV *ptr;
46 New(54, ptr, 1008/sizeof(XPV), XPV);
47 ptr->xpv_pv = (char*)PL_he_arenaroot;
48 PL_he_arenaroot = ptr;
49
50 he = (HE*)ptr;
4633a7c4 51 heend = &he[1008 / sizeof(HE) - 1];
612f20c3 52 PL_he_root = ++he;
4633a7c4 53 while (he < heend) {
fde52b5c 54 HeNEXT(he) = (HE*)(he + 1);
4633a7c4
LW
55 he++;
56 }
fde52b5c 57 HeNEXT(he) = 0;
4633a7c4
LW
58}
59
d33b2eba
GS
60#ifdef PURIFY
61
62#define new_HE() (HE*)safemalloc(sizeof(HE))
63#define del_HE(p) safefree((char*)p)
64
65#else
66
67#define new_HE() new_he()
68#define del_HE(p) del_he(p)
69
70#endif
71
76e3520e 72STATIC HEK *
cea2e8a9 73S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
bbce6d69
PP
74{
75 char *k;
76 register HEK *hek;
da58a35d
JH
77 bool is_utf8 = FALSE;
78
79 if (len < 0) {
80 len = -len;
81 is_utf8 = TRUE;
82 }
1c846c1f 83
ff68c719 84 New(54, k, HEK_BASESIZE + len + 1, char);
bbce6d69 85 hek = (HEK*)k;
ff68c719 86 Copy(str, HEK_KEY(hek), len, char);
ff68c719
PP
87 HEK_LEN(hek) = len;
88 HEK_HASH(hek) = hash;
da58a35d 89 HEK_UTF8(hek) = (char)is_utf8;
bbce6d69
PP
90 return hek;
91}
92
93void
864dbfa3 94Perl_unshare_hek(pTHX_ HEK *hek)
bbce6d69 95{
c3654f1a
IH
96 unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
97 HEK_HASH(hek));
bbce6d69
PP
98}
99
d18c6117
GS
100#if defined(USE_ITHREADS)
101HE *
a8fc9800 102Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
d18c6117
GS
103{
104 HE *ret;
105
106 if (!e)
107 return Nullhe;
7766f137
GS
108 /* look for it in the table first */
109 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
110 if (ret)
111 return ret;
112
113 /* create anew and remember what it is */
d33b2eba 114 ret = new_HE();
7766f137
GS
115 ptr_table_store(PL_ptr_table, e, ret);
116
d2d73c3e 117 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
d18c6117 118 if (HeKLEN(e) == HEf_SVKEY)
d2d73c3e 119 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
d18c6117 120 else if (shared)
c3654f1a 121 HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
d18c6117 122 else
c3654f1a 123 HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
d2d73c3e 124 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
d18c6117
GS
125 return ret;
126}
127#endif /* USE_ITHREADS */
128
fde52b5c
PP
129/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
130 * contains an SV* */
131
954c1994
GS
132/*
133=for apidoc hv_fetch
134
135Returns the SV which corresponds to the specified key in the hash. The
136C<klen> is the length of the key. If C<lval> is set then the fetch will be
137part of a store. Check that the return value is non-null before
1c846c1f 138dereferencing it to a C<SV*>.
954c1994 139
96f1132b 140See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
141information on how to use this function on tied hashes.
142
143=cut
144*/
145
79072805 146SV**
da58a35d 147Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
79072805 148{
cbec9347 149 register XPVHV* xhv;
fde52b5c 150 register U32 hash;
79072805 151 register HE *entry;
79072805 152 SV *sv;
da58a35d 153 bool is_utf8 = FALSE;
f9a63242 154 const char *keysave = key;
79072805
LW
155
156 if (!hv)
157 return 0;
463ee0b2 158
da58a35d
JH
159 if (klen < 0) {
160 klen = -klen;
161 is_utf8 = TRUE;
162 }
163
8990e307 164 if (SvRMAGICAL(hv)) {
14befaf4 165 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
8990e307 166 sv = sv_newmortal();
463ee0b2 167 mg_copy((SV*)hv, sv, key, klen);
3280af22
NIS
168 PL_hv_fetch_sv = sv;
169 return &PL_hv_fetch_sv;
463ee0b2 170 }
902173a3 171#ifdef ENV_IS_CASELESS
14befaf4 172 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
e7152ba2
GS
173 U32 i;
174 for (i = 0; i < klen; ++i)
175 if (isLOWER(key[i])) {
79cb57f6 176 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
e7152ba2
GS
177 SV **ret = hv_fetch(hv, nkey, klen, 0);
178 if (!ret && lval)
179 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
180 return ret;
181 }
902173a3
GS
182 }
183#endif
463ee0b2
LW
184 }
185
cbec9347
JH
186 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
187 avoid unnecessary pointer dereferencing. */
188 xhv = (XPVHV*)SvANY(hv);
189 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
1c846c1f 190 if (lval
a0d0e21e 191#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
cbec9347 192 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
a0d0e21e
LW
193#endif
194 )
cbec9347
JH
195 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
196 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
197 char);
79072805
LW
198 else
199 return 0;
200 }
201
77caf834 202 if (is_utf8) {
75a54232
JH
203 STRLEN tmplen = klen;
204 /* Just casting the &klen to (STRLEN) won't work well
205 * if STRLEN and I32 are of different widths. --jhi */
206 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
207 klen = tmplen;
208 }
f9a63242 209
fde52b5c 210 PERL_HASH(hash, key, klen);
79072805 211
cbec9347
JH
212 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
213 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
214 for (; entry; entry = HeNEXT(entry)) {
215 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 216 continue;
fde52b5c 217 if (HeKLEN(entry) != klen)
79072805 218 continue;
1c846c1f 219 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 220 continue;
c3654f1a
IH
221 if (HeKUTF8(entry) != (char)is_utf8)
222 continue;
f9a63242
JH
223 if (key != keysave)
224 Safefree(key);
fde52b5c 225 return &HeVAL(entry);
79072805 226 }
a0d0e21e 227#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
cbec9347 228 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364
GS
229 unsigned long len;
230 char *env = PerlEnv_ENVgetenv_len(key,&len);
231 if (env) {
232 sv = newSVpvn(env,len);
233 SvTAINTED_on(sv);
f9a63242
JH
234 if (key != keysave)
235 Safefree(key);
a6c40364
GS
236 return hv_store(hv,key,klen,sv,hash);
237 }
a0d0e21e
LW
238 }
239#endif
79072805
LW
240 if (lval) { /* gonna assign to this, so it better be there */
241 sv = NEWSV(61,0);
f9a63242
JH
242 if (key != keysave) { /* must be is_utf8 == 0 */
243 SV **ret = hv_store(hv,key,klen,sv,hash);
244 Safefree(key);
245 return ret;
246 }
247 else
248 return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
79072805 249 }
f9a63242
JH
250 if (key != keysave)
251 Safefree(key);
79072805
LW
252 return 0;
253}
254
fde52b5c
PP
255/* returns a HE * structure with the all fields set */
256/* note that hent_val will be a mortal sv for MAGICAL hashes */
954c1994
GS
257/*
258=for apidoc hv_fetch_ent
259
260Returns the hash entry which corresponds to the specified key in the hash.
261C<hash> must be a valid precomputed hash number for the given C<key>, or 0
262if you want the function to compute it. IF C<lval> is set then the fetch
263will be part of a store. Make sure the return value is non-null before
264accessing it. The return value when C<tb> is a tied hash is a pointer to a
265static location, so be sure to make a copy of the structure if you need to
1c846c1f 266store it somewhere.
954c1994 267
96f1132b 268See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
269information on how to use this function on tied hashes.
270
271=cut
272*/
273
fde52b5c 274HE *
864dbfa3 275Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
fde52b5c 276{
cbec9347 277 register XPVHV* xhv;
fde52b5c
PP
278 register char *key;
279 STRLEN klen;
280 register HE *entry;
281 SV *sv;
da58a35d 282 bool is_utf8;
f9a63242 283 char *keysave;
fde52b5c
PP
284
285 if (!hv)
286 return 0;
287
902173a3 288 if (SvRMAGICAL(hv)) {
14befaf4 289 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
902173a3
GS
290 sv = sv_newmortal();
291 keysv = sv_2mortal(newSVsv(keysv));
292 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
3280af22 293 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
902173a3
GS
294 char *k;
295 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
3280af22 296 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
902173a3 297 }
3280af22
NIS
298 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
299 HeVAL(&PL_hv_fetch_ent_mh) = sv;
300 return &PL_hv_fetch_ent_mh;
1cf368ac 301 }
902173a3 302#ifdef ENV_IS_CASELESS
14befaf4 303 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
e7152ba2 304 U32 i;
902173a3 305 key = SvPV(keysv, klen);
e7152ba2
GS
306 for (i = 0; i < klen; ++i)
307 if (isLOWER(key[i])) {
79cb57f6 308 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
e7152ba2
GS
309 (void)strupr(SvPVX(nkeysv));
310 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
311 if (!entry && lval)
312 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
313 return entry;
314 }
902173a3
GS
315 }
316#endif
fde52b5c
PP
317 }
318
cbec9347
JH
319 xhv = (XPVHV*)SvANY(hv);
320 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
1c846c1f 321 if (lval
fde52b5c 322#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
cbec9347 323 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
fde52b5c
PP
324#endif
325 )
cbec9347
JH
326 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
327 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
328 char);
fde52b5c
PP
329 else
330 return 0;
331 }
332
f9a63242 333 keysave = key = SvPV(keysv, klen);
da58a35d 334 is_utf8 = (SvUTF8(keysv)!=0);
1c846c1f 335
77caf834 336 if (is_utf8)
f9a63242
JH
337 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
338
effa1e2d
PP
339 if (!hash)
340 PERL_HASH(hash, key, klen);
341
cbec9347
JH
342 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
343 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
344 for (; entry; entry = HeNEXT(entry)) {
345 if (HeHASH(entry) != hash) /* strings can't be equal */
346 continue;
347 if (HeKLEN(entry) != klen)
348 continue;
1c846c1f 349 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 350 continue;
c3654f1a
IH
351 if (HeKUTF8(entry) != (char)is_utf8)
352 continue;
f9a63242
JH
353 if (key != keysave)
354 Safefree(key);
fde52b5c
PP
355 return entry;
356 }
357#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
cbec9347 358 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364
GS
359 unsigned long len;
360 char *env = PerlEnv_ENVgetenv_len(key,&len);
361 if (env) {
362 sv = newSVpvn(env,len);
363 SvTAINTED_on(sv);
364 return hv_store_ent(hv,keysv,sv,hash);
365 }
fde52b5c
PP
366 }
367#endif
f9a63242
JH
368 if (key != keysave)
369 Safefree(key);
fde52b5c
PP
370 if (lval) { /* gonna assign to this, so it better be there */
371 sv = NEWSV(61,0);
e7152ba2 372 return hv_store_ent(hv,keysv,sv,hash);
fde52b5c
PP
373 }
374 return 0;
375}
376
864dbfa3 377STATIC void
cea2e8a9 378S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
d0066dc7
OT
379{
380 MAGIC *mg = SvMAGIC(hv);
381 *needs_copy = FALSE;
382 *needs_store = TRUE;
383 while (mg) {
384 if (isUPPER(mg->mg_type)) {
385 *needs_copy = TRUE;
386 switch (mg->mg_type) {
14befaf4
DM
387 case PERL_MAGIC_tied:
388 case PERL_MAGIC_sig:
d0066dc7 389 *needs_store = FALSE;
d0066dc7
OT
390 }
391 }
392 mg = mg->mg_moremagic;
393 }
394}
395
954c1994
GS
396/*
397=for apidoc hv_store
398
399Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
400the length of the key. The C<hash> parameter is the precomputed hash
401value; if it is zero then Perl will compute it. The return value will be
402NULL if the operation failed or if the value did not need to be actually
403stored within the hash (as in the case of tied hashes). Otherwise it can
404be dereferenced to get the original C<SV*>. Note that the caller is
405responsible for suitably incrementing the reference count of C<val> before
1c846c1f 406the call, and decrementing it if the function returned NULL.
954c1994 407
96f1132b 408See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
409information on how to use this function on tied hashes.
410
411=cut
412*/
413
79072805 414SV**
da58a35d 415Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
79072805 416{
cbec9347 417 register XPVHV* xhv;
79072805
LW
418 register I32 i;
419 register HE *entry;
420 register HE **oentry;
da58a35d 421 bool is_utf8 = FALSE;
f9a63242 422 const char *keysave = key;
79072805
LW
423
424 if (!hv)
425 return 0;
426
da58a35d
JH
427 if (klen < 0) {
428 klen = -klen;
429 is_utf8 = TRUE;
430 }
431
cbec9347 432 xhv = (XPVHV*)SvANY(hv);
463ee0b2 433 if (SvMAGICAL(hv)) {
d0066dc7
OT
434 bool needs_copy;
435 bool needs_store;
436 hv_magic_check (hv, &needs_copy, &needs_store);
437 if (needs_copy) {
438 mg_copy((SV*)hv, val, key, klen);
cbec9347 439 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store)
d0066dc7 440 return 0;
902173a3 441#ifdef ENV_IS_CASELESS
14befaf4 442 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
d220deaf 443 key = savepvn(key,klen);
25716404 444 key = (const char*)strupr((char*)key);
902173a3
GS
445 hash = 0;
446 }
447#endif
d0066dc7 448 }
463ee0b2 449 }
77caf834 450 if (is_utf8) {
75a54232
JH
451 STRLEN tmplen = klen;
452 /* See the note in hv_fetch(). --jhi */
453 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
454 klen = tmplen;
455 }
f9a63242 456
fde52b5c
PP
457 if (!hash)
458 PERL_HASH(hash, key, klen);
459
cbec9347
JH
460 if (!xhv->xhv_array /* !HvARRAY(hv) */)
461 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
462 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
463 char);
fde52b5c 464
cbec9347
JH
465 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
466 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
467 i = 1;
468
469 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
470 if (HeHASH(entry) != hash) /* strings can't be equal */
471 continue;
472 if (HeKLEN(entry) != klen)
473 continue;
1c846c1f 474 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 475 continue;
c3654f1a
IH
476 if (HeKUTF8(entry) != (char)is_utf8)
477 continue;
fde52b5c
PP
478 SvREFCNT_dec(HeVAL(entry));
479 HeVAL(entry) = val;
f9a63242
JH
480 if (key != keysave)
481 Safefree(key);
fde52b5c
PP
482 return &HeVAL(entry);
483 }
484
d33b2eba 485 entry = new_HE();
fde52b5c 486 if (HvSHAREKEYS(hv))
c3654f1a 487 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
fde52b5c 488 else /* gotta do the real thing */
c3654f1a 489 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
f9a63242
JH
490 if (key != keysave)
491 Safefree(key);
fde52b5c 492 HeVAL(entry) = val;
fde52b5c
PP
493 HeNEXT(entry) = *oentry;
494 *oentry = entry;
495
cbec9347 496 xhv->xhv_keys++; /* HvKEYS(hv)++ */
fde52b5c 497 if (i) { /* initial entry? */
cbec9347
JH
498 xhv->xhv_fill++; /* HvFILL(hv)++ */
499 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
fde52b5c 500 hsplit(hv);
79072805
LW
501 }
502
fde52b5c
PP
503 return &HeVAL(entry);
504}
505
954c1994
GS
506/*
507=for apidoc hv_store_ent
508
509Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
510parameter is the precomputed hash value; if it is zero then Perl will
511compute it. The return value is the new hash entry so created. It will be
512NULL if the operation failed or if the value did not need to be actually
513stored within the hash (as in the case of tied hashes). Otherwise the
87324b0f 514contents of the return value can be accessed using the C<He?> macros
954c1994
GS
515described here. Note that the caller is responsible for suitably
516incrementing the reference count of C<val> before the call, and
1c846c1f 517decrementing it if the function returned NULL.
954c1994 518
96f1132b 519See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
520information on how to use this function on tied hashes.
521
522=cut
523*/
524
fde52b5c 525HE *
864dbfa3 526Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
fde52b5c 527{
cbec9347 528 register XPVHV* xhv;
fde52b5c
PP
529 register char *key;
530 STRLEN klen;
531 register I32 i;
532 register HE *entry;
533 register HE **oentry;
da58a35d 534 bool is_utf8;
f9a63242 535 char *keysave;
fde52b5c
PP
536
537 if (!hv)
538 return 0;
539
cbec9347 540 xhv = (XPVHV*)SvANY(hv);
fde52b5c 541 if (SvMAGICAL(hv)) {
d0066dc7
OT
542 bool needs_copy;
543 bool needs_store;
544 hv_magic_check (hv, &needs_copy, &needs_store);
545 if (needs_copy) {
3280af22
NIS
546 bool save_taint = PL_tainted;
547 if (PL_tainting)
548 PL_tainted = SvTAINTED(keysv);
d0066dc7
OT
549 keysv = sv_2mortal(newSVsv(keysv));
550 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
551 TAINT_IF(save_taint);
cbec9347 552 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
d0066dc7 553 return Nullhe;
902173a3 554#ifdef ENV_IS_CASELESS
14befaf4 555 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
902173a3 556 key = SvPV(keysv, klen);
79cb57f6 557 keysv = sv_2mortal(newSVpvn(key,klen));
902173a3
GS
558 (void)strupr(SvPVX(keysv));
559 hash = 0;
560 }
561#endif
562 }
fde52b5c
PP
563 }
564
f9a63242 565 keysave = key = SvPV(keysv, klen);
da58a35d 566 is_utf8 = (SvUTF8(keysv) != 0);
902173a3 567
77caf834 568 if (is_utf8)
f9a63242
JH
569 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
570
fde52b5c
PP
571 if (!hash)
572 PERL_HASH(hash, key, klen);
573
cbec9347
JH
574 if (!xhv->xhv_array /* !HvARRAY(hv) */)
575 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
576 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
577 char);
79072805 578
cbec9347
JH
579 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
580 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
79072805
LW
581 i = 1;
582
fde52b5c
PP
583 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
584 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 585 continue;
fde52b5c 586 if (HeKLEN(entry) != klen)
79072805 587 continue;
1c846c1f 588 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 589 continue;
c3654f1a
IH
590 if (HeKUTF8(entry) != (char)is_utf8)
591 continue;
fde52b5c
PP
592 SvREFCNT_dec(HeVAL(entry));
593 HeVAL(entry) = val;
f9a63242
JH
594 if (key != keysave)
595 Safefree(key);
fde52b5c 596 return entry;
79072805 597 }
79072805 598
d33b2eba 599 entry = new_HE();
fde52b5c 600 if (HvSHAREKEYS(hv))
25716404 601 HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
fde52b5c 602 else /* gotta do the real thing */
25716404 603 HeKEY_hek(entry) = save_hek(key, is_utf8?-(I32)klen:klen, hash);
f9a63242
JH
604 if (key != keysave)
605 Safefree(key);
fde52b5c 606 HeVAL(entry) = val;
fde52b5c 607 HeNEXT(entry) = *oentry;
79072805
LW
608 *oentry = entry;
609
cbec9347 610 xhv->xhv_keys++; /* HvKEYS(hv)++ */
79072805 611 if (i) { /* initial entry? */
cbec9347
JH
612 xhv->xhv_fill++; /* HvFILL(hv)++ */
613 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
79072805
LW
614 hsplit(hv);
615 }
79072805 616
fde52b5c 617 return entry;
79072805
LW
618}
619
954c1994
GS
620/*
621=for apidoc hv_delete
622
623Deletes a key/value pair in the hash. The value SV is removed from the
1c846c1f 624hash and returned to the caller. The C<klen> is the length of the key.
954c1994
GS
625The C<flags> value will normally be zero; if set to G_DISCARD then NULL
626will be returned.
627
628=cut
629*/
630
79072805 631SV *
da58a35d 632Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
79072805 633{
cbec9347 634 register XPVHV* xhv;
79072805 635 register I32 i;
fde52b5c 636 register U32 hash;
79072805
LW
637 register HE *entry;
638 register HE **oentry;
67a38de0 639 SV **svp;
79072805 640 SV *sv;
da58a35d 641 bool is_utf8 = FALSE;
f9a63242 642 const char *keysave = key;
79072805
LW
643
644 if (!hv)
645 return Nullsv;
da58a35d
JH
646 if (klen < 0) {
647 klen = -klen;
648 is_utf8 = TRUE;
649 }
8990e307 650 if (SvRMAGICAL(hv)) {
0a0bb7c7
OT
651 bool needs_copy;
652 bool needs_store;
653 hv_magic_check (hv, &needs_copy, &needs_store);
654
67a38de0
NIS
655 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
656 sv = *svp;
0a0bb7c7
OT
657 mg_clear(sv);
658 if (!needs_store) {
14befaf4
DM
659 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
660 /* No longer an element */
661 sv_unmagic(sv, PERL_MAGIC_tiedelem);
0a0bb7c7
OT
662 return sv;
663 }
664 return Nullsv; /* element cannot be deleted */
665 }
902173a3 666#ifdef ENV_IS_CASELESS
14befaf4 667 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
79cb57f6 668 sv = sv_2mortal(newSVpvn(key,klen));
2fd1c6b8
GS
669 key = strupr(SvPVX(sv));
670 }
902173a3 671#endif
2fd1c6b8 672 }
463ee0b2 673 }
cbec9347
JH
674 xhv = (XPVHV*)SvANY(hv);
675 if (!xhv->xhv_array /* !HvARRAY(hv) */)
79072805 676 return Nullsv;
fde52b5c 677
77caf834 678 if (is_utf8) {
75a54232
JH
679 STRLEN tmplen = klen;
680 /* See the note in hv_fetch(). --jhi */
681 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
682 klen = tmplen;
683 }
f9a63242 684
fde52b5c 685 PERL_HASH(hash, key, klen);
79072805 686
cbec9347
JH
687 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
688 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
79072805
LW
689 entry = *oentry;
690 i = 1;
fde52b5c
PP
691 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
692 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 693 continue;
fde52b5c 694 if (HeKLEN(entry) != klen)
79072805 695 continue;
1c846c1f 696 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 697 continue;
c3654f1a
IH
698 if (HeKUTF8(entry) != (char)is_utf8)
699 continue;
f9a63242
JH
700 if (key != keysave)
701 Safefree(key);
fde52b5c 702 *oentry = HeNEXT(entry);
79072805 703 if (i && !*oentry)
cbec9347 704 xhv->xhv_fill--; /* HvFILL(hv)-- */
748a9306
LW
705 if (flags & G_DISCARD)
706 sv = Nullsv;
94f7643d 707 else {
79d01fbf 708 sv = sv_2mortal(HeVAL(entry));
94f7643d
GS
709 HeVAL(entry) = &PL_sv_undef;
710 }
cbec9347 711 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
72940dca 712 HvLAZYDEL_on(hv);
a0d0e21e 713 else
68dc0745 714 hv_free_ent(hv, entry);
cbec9347 715 xhv->xhv_keys--; /* HvKEYS(hv)-- */
fde52b5c
PP
716 return sv;
717 }
f9a63242
JH
718 if (key != keysave)
719 Safefree(key);
fde52b5c
PP
720 return Nullsv;
721}
722
954c1994
GS
723/*
724=for apidoc hv_delete_ent
725
726Deletes a key/value pair in the hash. The value SV is removed from the
727hash and returned to the caller. The C<flags> value will normally be zero;
728if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
729precomputed hash value, or 0 to ask for it to be computed.
730
731=cut
732*/
733
fde52b5c 734SV *
864dbfa3 735Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
fde52b5c 736{
cbec9347 737 register XPVHV* xhv;
fde52b5c
PP
738 register I32 i;
739 register char *key;
740 STRLEN klen;
741 register HE *entry;
742 register HE **oentry;
743 SV *sv;
da58a35d 744 bool is_utf8;
f9a63242 745 char *keysave;
1c846c1f 746
fde52b5c
PP
747 if (!hv)
748 return Nullsv;
749 if (SvRMAGICAL(hv)) {
0a0bb7c7
OT
750 bool needs_copy;
751 bool needs_store;
752 hv_magic_check (hv, &needs_copy, &needs_store);
753
67a38de0 754 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
0a0bb7c7
OT
755 sv = HeVAL(entry);
756 mg_clear(sv);
757 if (!needs_store) {
14befaf4
DM
758 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
759 /* No longer an element */
760 sv_unmagic(sv, PERL_MAGIC_tiedelem);
0a0bb7c7
OT
761 return sv;
762 }
763 return Nullsv; /* element cannot be deleted */
764 }
902173a3 765#ifdef ENV_IS_CASELESS
14befaf4 766 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
2fd1c6b8 767 key = SvPV(keysv, klen);
79cb57f6 768 keysv = sv_2mortal(newSVpvn(key,klen));
2fd1c6b8 769 (void)strupr(SvPVX(keysv));
1c846c1f 770 hash = 0;
2fd1c6b8 771 }
902173a3 772#endif
2fd1c6b8 773 }
fde52b5c 774 }
cbec9347
JH
775 xhv = (XPVHV*)SvANY(hv);
776 if (!xhv->xhv_array /* !HvARRAY(hv) */)
fde52b5c
PP
777 return Nullsv;
778
f9a63242 779 keysave = key = SvPV(keysv, klen);
da58a35d 780 is_utf8 = (SvUTF8(keysv) != 0);
1c846c1f 781
77caf834 782 if (is_utf8)
f9a63242
JH
783 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
784
fde52b5c
PP
785 if (!hash)
786 PERL_HASH(hash, key, klen);
787
cbec9347
JH
788 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
789 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
790 entry = *oentry;
791 i = 1;
792 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
793 if (HeHASH(entry) != hash) /* strings can't be equal */
794 continue;
795 if (HeKLEN(entry) != klen)
796 continue;
1c846c1f 797 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 798 continue;
c3654f1a
IH
799 if (HeKUTF8(entry) != (char)is_utf8)
800 continue;
f9a63242
JH
801 if (key != keysave)
802 Safefree(key);
fde52b5c
PP
803 *oentry = HeNEXT(entry);
804 if (i && !*oentry)
cbec9347 805 xhv->xhv_fill--; /* HvFILL(hv)-- */
fde52b5c
PP
806 if (flags & G_DISCARD)
807 sv = Nullsv;
94f7643d 808 else {
79d01fbf 809 sv = sv_2mortal(HeVAL(entry));
94f7643d
GS
810 HeVAL(entry) = &PL_sv_undef;
811 }
cbec9347 812 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
72940dca 813 HvLAZYDEL_on(hv);
fde52b5c 814 else
68dc0745 815 hv_free_ent(hv, entry);
cbec9347 816 xhv->xhv_keys--; /* HvKEYS(hv)-- */
79072805
LW
817 return sv;
818 }
f9a63242
JH
819 if (key != keysave)
820 Safefree(key);
79072805 821 return Nullsv;
79072805
LW
822}
823
954c1994
GS
824/*
825=for apidoc hv_exists
826
827Returns a boolean indicating whether the specified hash key exists. The
828C<klen> is the length of the key.
829
830=cut
831*/
832
a0d0e21e 833bool
da58a35d 834Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
a0d0e21e 835{
cbec9347 836 register XPVHV* xhv;
fde52b5c 837 register U32 hash;
a0d0e21e
LW
838 register HE *entry;
839 SV *sv;
da58a35d 840 bool is_utf8 = FALSE;
f9a63242 841 const char *keysave = key;
a0d0e21e
LW
842
843 if (!hv)
844 return 0;
845
da58a35d
JH
846 if (klen < 0) {
847 klen = -klen;
848 is_utf8 = TRUE;
849 }
850
a0d0e21e 851 if (SvRMAGICAL(hv)) {
14befaf4 852 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
a0d0e21e 853 sv = sv_newmortal();
1c846c1f 854 mg_copy((SV*)hv, sv, key, klen);
14befaf4 855 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
a0d0e21e
LW
856 return SvTRUE(sv);
857 }
902173a3 858#ifdef ENV_IS_CASELESS
14befaf4 859 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
79cb57f6 860 sv = sv_2mortal(newSVpvn(key,klen));
902173a3
GS
861 key = strupr(SvPVX(sv));
862 }
863#endif
a0d0e21e
LW
864 }
865
cbec9347 866 xhv = (XPVHV*)SvANY(hv);
f675dbe5 867#ifndef DYNAMIC_ENV_FETCH
cbec9347 868 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1c846c1f 869 return 0;
f675dbe5 870#endif
a0d0e21e 871
77caf834 872 if (is_utf8) {
75a54232
JH
873 STRLEN tmplen = klen;
874 /* See the note in hv_fetch(). --jhi */
875 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
876 klen = tmplen;
877 }
f9a63242 878
fde52b5c 879 PERL_HASH(hash, key, klen);
a0d0e21e 880
f675dbe5 881#ifdef DYNAMIC_ENV_FETCH
cbec9347 882 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
f675dbe5
CB
883 else
884#endif
cbec9347
JH
885 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
886 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
887 for (; entry; entry = HeNEXT(entry)) {
888 if (HeHASH(entry) != hash) /* strings can't be equal */
a0d0e21e 889 continue;
fde52b5c 890 if (HeKLEN(entry) != klen)
a0d0e21e 891 continue;
1c846c1f 892 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 893 continue;
c3654f1a
IH
894 if (HeKUTF8(entry) != (char)is_utf8)
895 continue;
f9a63242
JH
896 if (key != keysave)
897 Safefree(key);
fde52b5c
PP
898 return TRUE;
899 }
f675dbe5 900#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
cbec9347 901 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364
GS
902 unsigned long len;
903 char *env = PerlEnv_ENVgetenv_len(key,&len);
904 if (env) {
905 sv = newSVpvn(env,len);
906 SvTAINTED_on(sv);
907 (void)hv_store(hv,key,klen,sv,hash);
908 return TRUE;
909 }
f675dbe5
CB
910 }
911#endif
f9a63242
JH
912 if (key != keysave)
913 Safefree(key);
fde52b5c
PP
914 return FALSE;
915}
916
917
954c1994
GS
918/*
919=for apidoc hv_exists_ent
920
921Returns a boolean indicating whether the specified hash key exists. C<hash>
922can be a valid precomputed hash value, or 0 to ask for it to be
923computed.
924
925=cut
926*/
927
fde52b5c 928bool
864dbfa3 929Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
fde52b5c 930{
cbec9347 931 register XPVHV* xhv;
fde52b5c
PP
932 register char *key;
933 STRLEN klen;
934 register HE *entry;
935 SV *sv;
c3654f1a 936 bool is_utf8;
f9a63242 937 char *keysave;
fde52b5c
PP
938
939 if (!hv)
940 return 0;
941
942 if (SvRMAGICAL(hv)) {
14befaf4 943 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
62815d3c 944 SV* svret = sv_newmortal();
fde52b5c 945 sv = sv_newmortal();
effa1e2d 946 keysv = sv_2mortal(newSVsv(keysv));
1c846c1f 947 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
14befaf4 948 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
62815d3c 949 return SvTRUE(svret);
fde52b5c 950 }
902173a3 951#ifdef ENV_IS_CASELESS
14befaf4 952 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
902173a3 953 key = SvPV(keysv, klen);
79cb57f6 954 keysv = sv_2mortal(newSVpvn(key,klen));
902173a3 955 (void)strupr(SvPVX(keysv));
1c846c1f 956 hash = 0;
902173a3
GS
957 }
958#endif
fde52b5c
PP
959 }
960
cbec9347 961 xhv = (XPVHV*)SvANY(hv);
f675dbe5 962#ifndef DYNAMIC_ENV_FETCH
cbec9347 963 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1c846c1f 964 return 0;
f675dbe5 965#endif
fde52b5c 966
f9a63242 967 keysave = key = SvPV(keysv, klen);
c3654f1a 968 is_utf8 = (SvUTF8(keysv) != 0);
77caf834 969 if (is_utf8)
f9a63242 970 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
fde52b5c
PP
971 if (!hash)
972 PERL_HASH(hash, key, klen);
973
f675dbe5 974#ifdef DYNAMIC_ENV_FETCH
cbec9347 975 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
f675dbe5
CB
976 else
977#endif
cbec9347
JH
978 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
979 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
980 for (; entry; entry = HeNEXT(entry)) {
981 if (HeHASH(entry) != hash) /* strings can't be equal */
982 continue;
983 if (HeKLEN(entry) != klen)
984 continue;
1c846c1f 985 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
a0d0e21e 986 continue;
c3654f1a
IH
987 if (HeKUTF8(entry) != (char)is_utf8)
988 continue;
f9a63242
JH
989 if (key != keysave)
990 Safefree(key);
a0d0e21e
LW
991 return TRUE;
992 }
f675dbe5 993#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
cbec9347 994 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364
GS
995 unsigned long len;
996 char *env = PerlEnv_ENVgetenv_len(key,&len);
997 if (env) {
998 sv = newSVpvn(env,len);
999 SvTAINTED_on(sv);
1000 (void)hv_store_ent(hv,keysv,sv,hash);
1001 return TRUE;
1002 }
f675dbe5
CB
1003 }
1004#endif
f9a63242
JH
1005 if (key != keysave)
1006 Safefree(key);
a0d0e21e
LW
1007 return FALSE;
1008}
1009
76e3520e 1010STATIC void
cea2e8a9 1011S_hsplit(pTHX_ HV *hv)
79072805 1012{
cbec9347
JH
1013 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1014 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
79072805
LW
1015 register I32 newsize = oldsize * 2;
1016 register I32 i;
cbec9347 1017 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
72311751
GS
1018 register HE **aep;
1019 register HE **bep;
79072805
LW
1020 register HE *entry;
1021 register HE **oentry;
1022
3280af22 1023 PL_nomemok = TRUE;
8d6dde3e 1024#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1025 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1026 if (!a) {
4a33f861 1027 PL_nomemok = FALSE;
422a93e5
GA
1028 return;
1029 }
4633a7c4 1030#else
d18c6117 1031 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1032 if (!a) {
3280af22 1033 PL_nomemok = FALSE;
422a93e5
GA
1034 return;
1035 }
cbec9347 1036 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
fba3b22e 1037 if (oldsize >= 64) {
cbec9347
JH
1038 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1039 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
4633a7c4
LW
1040 }
1041 else
cbec9347 1042 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
4633a7c4
LW
1043#endif
1044
3280af22 1045 PL_nomemok = FALSE;
72311751 1046 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
cbec9347
JH
1047 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1048 xhv->xhv_array = a; /* HvARRAY(hv) = a */
72311751 1049 aep = (HE**)a;
79072805 1050
72311751
GS
1051 for (i=0; i<oldsize; i++,aep++) {
1052 if (!*aep) /* non-existent */
79072805 1053 continue;
72311751
GS
1054 bep = aep+oldsize;
1055 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
fde52b5c
PP
1056 if ((HeHASH(entry) & newsize) != i) {
1057 *oentry = HeNEXT(entry);
72311751
GS
1058 HeNEXT(entry) = *bep;
1059 if (!*bep)
cbec9347 1060 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1061 *bep = entry;
79072805
LW
1062 continue;
1063 }
1064 else
fde52b5c 1065 oentry = &HeNEXT(entry);
79072805 1066 }
72311751 1067 if (!*aep) /* everything moved */
cbec9347 1068 xhv->xhv_fill--; /* HvFILL(hv)-- */
79072805
LW
1069 }
1070}
1071
72940dca 1072void
864dbfa3 1073Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 1074{
cbec9347
JH
1075 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1076 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
72940dca
PP
1077 register I32 newsize;
1078 register I32 i;
1079 register I32 j;
72311751
GS
1080 register char *a;
1081 register HE **aep;
72940dca
PP
1082 register HE *entry;
1083 register HE **oentry;
1084
1085 newsize = (I32) newmax; /* possible truncation here */
1086 if (newsize != newmax || newmax <= oldsize)
1087 return;
1088 while ((newsize & (1 + ~newsize)) != newsize) {
1089 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1090 }
1091 if (newsize < newmax)
1092 newsize *= 2;
1093 if (newsize < newmax)
1094 return; /* overflow detection */
1095
cbec9347 1096 a = xhv->xhv_array; /* HvARRAY(hv) */
72940dca 1097 if (a) {
3280af22 1098 PL_nomemok = TRUE;
8d6dde3e 1099#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1100 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1101 if (!a) {
4a33f861 1102 PL_nomemok = FALSE;
422a93e5
GA
1103 return;
1104 }
72940dca 1105#else
d18c6117 1106 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1107 if (!a) {
3280af22 1108 PL_nomemok = FALSE;
422a93e5
GA
1109 return;
1110 }
cbec9347 1111 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
fba3b22e 1112 if (oldsize >= 64) {
cbec9347
JH
1113 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1114 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
72940dca
PP
1115 }
1116 else
cbec9347 1117 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
72940dca 1118#endif
3280af22 1119 PL_nomemok = FALSE;
72311751 1120 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca
PP
1121 }
1122 else {
d18c6117 1123 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
72940dca 1124 }
cbec9347
JH
1125 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1126 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1127 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
72940dca
PP
1128 return;
1129
72311751
GS
1130 aep = (HE**)a;
1131 for (i=0; i<oldsize; i++,aep++) {
1132 if (!*aep) /* non-existent */
72940dca 1133 continue;
72311751 1134 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
72940dca
PP
1135 if ((j = (HeHASH(entry) & newsize)) != i) {
1136 j -= i;
1137 *oentry = HeNEXT(entry);
72311751 1138 if (!(HeNEXT(entry) = aep[j]))
cbec9347 1139 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1140 aep[j] = entry;
72940dca
PP
1141 continue;
1142 }
1143 else
1144 oentry = &HeNEXT(entry);
1145 }
72311751 1146 if (!*aep) /* everything moved */
cbec9347 1147 xhv->xhv_fill--; /* HvFILL(hv)-- */
72940dca
PP
1148 }
1149}
1150
954c1994
GS
1151/*
1152=for apidoc newHV
1153
1154Creates a new HV. The reference count is set to 1.
1155
1156=cut
1157*/
1158
79072805 1159HV *
864dbfa3 1160Perl_newHV(pTHX)
79072805
LW
1161{
1162 register HV *hv;
cbec9347 1163 register XPVHV* xhv;
79072805 1164
a0d0e21e
LW
1165 hv = (HV*)NEWSV(502,0);
1166 sv_upgrade((SV *)hv, SVt_PVHV);
cbec9347 1167 xhv = (XPVHV*)SvANY(hv);
79072805
LW
1168 SvPOK_off(hv);
1169 SvNOK_off(hv);
1c846c1f 1170#ifndef NODEFAULT_SHAREKEYS
fde52b5c 1171 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1c846c1f 1172#endif
cbec9347
JH
1173 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1174 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1175 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
79072805
LW
1176 (void)hv_iterinit(hv); /* so each() will start off right */
1177 return hv;
1178}
1179
b3ac6de7 1180HV *
864dbfa3 1181Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 1182{
b56ba0bf 1183 HV *hv = newHV();
4beac62f 1184 STRLEN hv_max, hv_fill;
4beac62f
AMS
1185
1186 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1187 return hv;
4beac62f 1188 hv_max = HvMAX(ohv);
b3ac6de7 1189
b56ba0bf
AMS
1190 if (!SvMAGICAL((SV *)ohv)) {
1191 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1192 int i, shared = !!HvSHAREKEYS(ohv);
1193 HE **ents, **oents = (HE **)HvARRAY(ohv);
ff875642
JH
1194 char *a;
1195 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1196 ents = (HE**)a;
b56ba0bf
AMS
1197
1198 /* In each bucket... */
1199 for (i = 0; i <= hv_max; i++) {
1200 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1201
1202 if (!oent) {
1203 ents[i] = NULL;
1204 continue;
1205 }
1206
1207 /* Copy the linked list of entries. */
1208 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1209 U32 hash = HeHASH(oent);
1210 char *key = HeKEY(oent);
1211 STRLEN len = HeKLEN_UTF8(oent);
1212
1213 ent = new_HE();
45dea987 1214 HeVAL(ent) = newSVsv(HeVAL(oent));
b56ba0bf
AMS
1215 HeKEY_hek(ent) = shared ? share_hek(key, len, hash)
1216 : save_hek(key, len, hash);
1217 if (prev)
1218 HeNEXT(prev) = ent;
1219 else
1220 ents[i] = ent;
1221 prev = ent;
1222 HeNEXT(ent) = NULL;
1223 }
1224 }
1225
1226 HvMAX(hv) = hv_max;
1227 HvFILL(hv) = hv_fill;
1228 HvKEYS(hv) = HvKEYS(ohv);
1229 HvARRAY(hv) = ents;
1c846c1f 1230 }
b56ba0bf
AMS
1231 else {
1232 /* Iterate over ohv, copying keys and values one at a time. */
b3ac6de7 1233 HE *entry;
b56ba0bf
AMS
1234 I32 riter = HvRITER(ohv);
1235 HE *eiter = HvEITER(ohv);
1236
1237 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1238 while (hv_max && hv_max + 1 >= hv_fill * 2)
1239 hv_max = hv_max / 2;
1240 HvMAX(hv) = hv_max;
1241
4a76a316 1242 hv_iterinit(ohv);
155aba94 1243 while ((entry = hv_iternext(ohv))) {
c3654f1a 1244 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
00122d59 1245 newSVsv(HeVAL(entry)), HeHASH(entry));
b3ac6de7 1246 }
b56ba0bf
AMS
1247 HvRITER(ohv) = riter;
1248 HvEITER(ohv) = eiter;
b3ac6de7 1249 }
1c846c1f 1250
b3ac6de7
IZ
1251 return hv;
1252}
1253
79072805 1254void
864dbfa3 1255Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 1256{
16bdeea2
GS
1257 SV *val;
1258
68dc0745 1259 if (!entry)
79072805 1260 return;
16bdeea2 1261 val = HeVAL(entry);
257c9e5b 1262 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
3280af22 1263 PL_sub_generation++; /* may be deletion of method from stash */
16bdeea2 1264 SvREFCNT_dec(val);
68dc0745
PP
1265 if (HeKLEN(entry) == HEf_SVKEY) {
1266 SvREFCNT_dec(HeKEY_sv(entry));
1267 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1268 }
1269 else if (HvSHAREKEYS(hv))
68dc0745 1270 unshare_hek(HeKEY_hek(entry));
fde52b5c 1271 else
68dc0745 1272 Safefree(HeKEY_hek(entry));
d33b2eba 1273 del_HE(entry);
79072805
LW
1274}
1275
1276void
864dbfa3 1277Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 1278{
68dc0745 1279 if (!entry)
79072805 1280 return;
68dc0745 1281 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
3280af22 1282 PL_sub_generation++; /* may be deletion of method from stash */
68dc0745
PP
1283 sv_2mortal(HeVAL(entry)); /* free between statements */
1284 if (HeKLEN(entry) == HEf_SVKEY) {
1285 sv_2mortal(HeKEY_sv(entry));
1286 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1287 }
1288 else if (HvSHAREKEYS(hv))
68dc0745 1289 unshare_hek(HeKEY_hek(entry));
fde52b5c 1290 else
68dc0745 1291 Safefree(HeKEY_hek(entry));
d33b2eba 1292 del_HE(entry);
79072805
LW
1293}
1294
954c1994
GS
1295/*
1296=for apidoc hv_clear
1297
1298Clears a hash, making it empty.
1299
1300=cut
1301*/
1302
79072805 1303void
864dbfa3 1304Perl_hv_clear(pTHX_ HV *hv)
79072805 1305{
cbec9347 1306 register XPVHV* xhv;
79072805
LW
1307 if (!hv)
1308 return;
cbec9347 1309 xhv = (XPVHV*)SvANY(hv);
463ee0b2 1310 hfreeentries(hv);
cbec9347
JH
1311 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1312 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1313 if (xhv->xhv_array /* HvARRAY(hv) */)
1314 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1315 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
a0d0e21e
LW
1316
1317 if (SvRMAGICAL(hv))
1c846c1f 1318 mg_clear((SV*)hv);
79072805
LW
1319}
1320
76e3520e 1321STATIC void
cea2e8a9 1322S_hfreeentries(pTHX_ HV *hv)
79072805 1323{
a0d0e21e 1324 register HE **array;
68dc0745
PP
1325 register HE *entry;
1326 register HE *oentry = Null(HE*);
a0d0e21e
LW
1327 I32 riter;
1328 I32 max;
79072805
LW
1329
1330 if (!hv)
1331 return;
a0d0e21e 1332 if (!HvARRAY(hv))
79072805 1333 return;
a0d0e21e
LW
1334
1335 riter = 0;
1336 max = HvMAX(hv);
1337 array = HvARRAY(hv);
68dc0745 1338 entry = array[0];
a0d0e21e 1339 for (;;) {
68dc0745
PP
1340 if (entry) {
1341 oentry = entry;
1342 entry = HeNEXT(entry);
1343 hv_free_ent(hv, oentry);
a0d0e21e 1344 }
68dc0745 1345 if (!entry) {
a0d0e21e
LW
1346 if (++riter > max)
1347 break;
68dc0745 1348 entry = array[riter];
1c846c1f 1349 }
79072805 1350 }
a0d0e21e 1351 (void)hv_iterinit(hv);
79072805
LW
1352}
1353
954c1994
GS
1354/*
1355=for apidoc hv_undef
1356
1357Undefines the hash.
1358
1359=cut
1360*/
1361
79072805 1362void
864dbfa3 1363Perl_hv_undef(pTHX_ HV *hv)
79072805 1364{
cbec9347 1365 register XPVHV* xhv;
79072805
LW
1366 if (!hv)
1367 return;
cbec9347 1368 xhv = (XPVHV*)SvANY(hv);
463ee0b2 1369 hfreeentries(hv);
cbec9347 1370 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
85e6fe83
LW
1371 if (HvNAME(hv)) {
1372 Safefree(HvNAME(hv));
1373 HvNAME(hv) = 0;
1374 }
cbec9347
JH
1375 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1376 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1377 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1378 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
a0d0e21e
LW
1379
1380 if (SvRMAGICAL(hv))
1c846c1f 1381 mg_clear((SV*)hv);
79072805
LW
1382}
1383
954c1994
GS
1384/*
1385=for apidoc hv_iterinit
1386
1387Prepares a starting point to traverse a hash table. Returns the number of
1388keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1c846c1f 1389currently only meaningful for hashes without tie magic.
954c1994
GS
1390
1391NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1392hash buckets that happen to be in use. If you still need that esoteric
1393value, you can get it through the macro C<HvFILL(tb)>.
1394
1395=cut
1396*/
1397
79072805 1398I32
864dbfa3 1399Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1400{
cbec9347 1401 register XPVHV* xhv;
aa689395
PP
1402 HE *entry;
1403
1404 if (!hv)
cea2e8a9 1405 Perl_croak(aTHX_ "Bad hash");
cbec9347
JH
1406 xhv = (XPVHV*)SvANY(hv);
1407 entry = xhv->xhv_eiter; /* HvEITER(hv) */
72940dca
PP
1408 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1409 HvLAZYDEL_off(hv);
68dc0745 1410 hv_free_ent(hv, entry);
72940dca 1411 }
cbec9347
JH
1412 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1413 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1414 /* used to be xhv->xhv_fill before 5.004_65 */
1415 return xhv->xhv_keys; /* HvKEYS(hv) */
79072805
LW
1416}
1417
954c1994
GS
1418/*
1419=for apidoc hv_iternext
1420
1421Returns entries from a hash iterator. See C<hv_iterinit>.
1422
1423=cut
1424*/
1425
79072805 1426HE *
864dbfa3 1427Perl_hv_iternext(pTHX_ HV *hv)
79072805 1428{
cbec9347 1429 register XPVHV* xhv;
79072805 1430 register HE *entry;
a0d0e21e 1431 HE *oldentry;
463ee0b2 1432 MAGIC* mg;
79072805
LW
1433
1434 if (!hv)
cea2e8a9 1435 Perl_croak(aTHX_ "Bad hash");
cbec9347
JH
1436 xhv = (XPVHV*)SvANY(hv);
1437 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
463ee0b2 1438
14befaf4 1439 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
8990e307 1440 SV *key = sv_newmortal();
cd1469e6 1441 if (entry) {
fde52b5c 1442 sv_setsv(key, HeSVKEY_force(entry));
cd1469e6
PP
1443 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1444 }
a0d0e21e 1445 else {
ff68c719 1446 char *k;
bbce6d69 1447 HEK *hek;
ff68c719 1448
cbec9347
JH
1449 /* one HE per MAGICAL hash */
1450 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
4633a7c4 1451 Zero(entry, 1, HE);
ff68c719
PP
1452 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1453 hek = (HEK*)k;
1454 HeKEY_hek(entry) = hek;
fde52b5c 1455 HeKLEN(entry) = HEf_SVKEY;
a0d0e21e
LW
1456 }
1457 magic_nextpack((SV*) hv,mg,key);
463ee0b2 1458 if (SvOK(key)) {
cd1469e6 1459 /* force key to stay around until next time */
bbce6d69
PP
1460 HeSVKEY_set(entry, SvREFCNT_inc(key));
1461 return entry; /* beware, hent_val is not set */
463ee0b2 1462 }
fde52b5c
PP
1463 if (HeVAL(entry))
1464 SvREFCNT_dec(HeVAL(entry));
ff68c719 1465 Safefree(HeKEY_hek(entry));
d33b2eba 1466 del_HE(entry);
cbec9347 1467 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
463ee0b2 1468 return Null(HE*);
79072805 1469 }
f675dbe5 1470#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
cbec9347 1471 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
f675dbe5
CB
1472 prime_env_iter();
1473#endif
463ee0b2 1474
cbec9347
JH
1475 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1476 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1477 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1478 char);
fde52b5c
PP
1479 if (entry)
1480 entry = HeNEXT(entry);
1481 while (!entry) {
cbec9347
JH
1482 xhv->xhv_riter++; /* HvRITER(hv)++ */
1483 if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1484 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
fde52b5c 1485 break;
79072805 1486 }
cbec9347
JH
1487 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1488 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
fde52b5c 1489 }
79072805 1490
72940dca
PP
1491 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1492 HvLAZYDEL_off(hv);
68dc0745 1493 hv_free_ent(hv, oldentry);
72940dca 1494 }
a0d0e21e 1495
cbec9347 1496 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
79072805
LW
1497 return entry;
1498}
1499
954c1994
GS
1500/*
1501=for apidoc hv_iterkey
1502
1503Returns the key from the current position of the hash iterator. See
1504C<hv_iterinit>.
1505
1506=cut
1507*/
1508
79072805 1509char *
864dbfa3 1510Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 1511{
fde52b5c 1512 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a
PP
1513 STRLEN len;
1514 char *p = SvPV(HeKEY_sv(entry), len);
1515 *retlen = len;
1516 return p;
fde52b5c
PP
1517 }
1518 else {
1519 *retlen = HeKLEN(entry);
1520 return HeKEY(entry);
1521 }
1522}
1523
1524/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994
GS
1525/*
1526=for apidoc hv_iterkeysv
1527
1528Returns the key as an C<SV*> from the current position of the hash
1529iterator. The return value will always be a mortal copy of the key. Also
1530see C<hv_iterinit>.
1531
1532=cut
1533*/
1534
fde52b5c 1535SV *
864dbfa3 1536Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c
PP
1537{
1538 if (HeKLEN(entry) == HEf_SVKEY)
bbce6d69 1539 return sv_mortalcopy(HeKEY_sv(entry));
c3654f1a
IH
1540 else
1541 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1542 HeKLEN_UTF8(entry), HeHASH(entry)));
79072805
LW
1543}
1544
954c1994
GS
1545/*
1546=for apidoc hv_iterval
1547
1548Returns the value from the current position of the hash iterator. See
1549C<hv_iterkey>.
1550
1551=cut
1552*/
1553
79072805 1554SV *
864dbfa3 1555Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 1556{
8990e307 1557 if (SvRMAGICAL(hv)) {
14befaf4 1558 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
8990e307 1559 SV* sv = sv_newmortal();
bbce6d69
PP
1560 if (HeKLEN(entry) == HEf_SVKEY)
1561 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1562 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2
LW
1563 return sv;
1564 }
79072805 1565 }
fde52b5c 1566 return HeVAL(entry);
79072805
LW
1567}
1568
954c1994
GS
1569/*
1570=for apidoc hv_iternextsv
1571
1572Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1573operation.
1574
1575=cut
1576*/
1577
a0d0e21e 1578SV *
864dbfa3 1579Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e
LW
1580{
1581 HE *he;
1582 if ( (he = hv_iternext(hv)) == NULL)
1583 return NULL;
1584 *key = hv_iterkey(he, retlen);
1585 return hv_iterval(hv, he);
1586}
1587
954c1994
GS
1588/*
1589=for apidoc hv_magic
1590
1591Adds magic to a hash. See C<sv_magic>.
1592
1593=cut
1594*/
1595
79072805 1596void
864dbfa3 1597Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
79072805 1598{
a0d0e21e 1599 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
79072805 1600}
fde52b5c 1601
bbce6d69 1602char*
864dbfa3 1603Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
bbce6d69 1604{
ff68c719 1605 return HEK_KEY(share_hek(sv, len, hash));
bbce6d69
PP
1606}
1607
1608/* possibly free a shared string if no one has access to it
fde52b5c
PP
1609 * len and hash must both be valid for str.
1610 */
bbce6d69 1611void
864dbfa3 1612Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 1613{
cbec9347 1614 register XPVHV* xhv;
fde52b5c
PP
1615 register HE *entry;
1616 register HE **oentry;
1617 register I32 i = 1;
1618 I32 found = 0;
c3654f1a 1619 bool is_utf8 = FALSE;
f9a63242 1620 const char *save = str;
c3654f1a
IH
1621
1622 if (len < 0) {
77caf834 1623 STRLEN tmplen = -len;
c3654f1a 1624 is_utf8 = TRUE;
77caf834
JH
1625 /* See the note in hv_fetch(). --jhi */
1626 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1627 len = tmplen;
c3654f1a 1628 }
1c846c1f 1629
fde52b5c 1630 /* what follows is the moral equivalent of:
6b88bc9c 1631 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
bbce6d69 1632 if (--*Svp == Nullsv)
6b88bc9c 1633 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 1634 } */
cbec9347 1635 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 1636 /* assert(xhv_array != 0) */
5f08fbcd 1637 LOCK_STRTAB_MUTEX;
cbec9347
JH
1638 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1639 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 1640 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
fde52b5c
PP
1641 if (HeHASH(entry) != hash) /* strings can't be equal */
1642 continue;
1643 if (HeKLEN(entry) != len)
1644 continue;
1c846c1f 1645 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 1646 continue;
c3654f1a
IH
1647 if (HeKUTF8(entry) != (char)is_utf8)
1648 continue;
fde52b5c 1649 found = 1;
bbce6d69
PP
1650 if (--HeVAL(entry) == Nullsv) {
1651 *oentry = HeNEXT(entry);
1652 if (i && !*oentry)
cbec9347 1653 xhv->xhv_fill--; /* HvFILL(hv)-- */
ff68c719 1654 Safefree(HeKEY_hek(entry));
d33b2eba 1655 del_HE(entry);
cbec9347 1656 xhv->xhv_keys--; /* HvKEYS(hv)-- */
fde52b5c 1657 }
bbce6d69 1658 break;
fde52b5c 1659 }
333f433b 1660 UNLOCK_STRTAB_MUTEX;
f9a63242
JH
1661 if (str != save)
1662 Safefree(str);
411caa50
JH
1663 if (!found && ckWARN_d(WARN_INTERNAL))
1664 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
fde52b5c
PP
1665}
1666
bbce6d69
PP
1667/* get a (constant) string ptr from the global string table
1668 * string will get added if it is not already there.
fde52b5c
PP
1669 * len and hash must both be valid for str.
1670 */
bbce6d69 1671HEK *
864dbfa3 1672Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 1673{
cbec9347 1674 register XPVHV* xhv;
fde52b5c
PP
1675 register HE *entry;
1676 register HE **oentry;
1677 register I32 i = 1;
1678 I32 found = 0;
da58a35d 1679 bool is_utf8 = FALSE;
f9a63242 1680 const char *save = str;
da58a35d
JH
1681
1682 if (len < 0) {
77caf834 1683 STRLEN tmplen = -len;
da58a35d 1684 is_utf8 = TRUE;
77caf834
JH
1685 /* See the note in hv_fetch(). --jhi */
1686 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1687 len = tmplen;
da58a35d 1688 }
bbce6d69 1689
fde52b5c 1690 /* what follows is the moral equivalent of:
1c846c1f 1691
6b88bc9c
GS
1692 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1693 hv_store(PL_strtab, str, len, Nullsv, hash);
bbce6d69 1694 */
cbec9347 1695 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 1696 /* assert(xhv_array != 0) */
5f08fbcd 1697 LOCK_STRTAB_MUTEX;
cbec9347
JH
1698 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1699 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 1700 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
fde52b5c
PP
1701 if (HeHASH(entry) != hash) /* strings can't be equal */
1702 continue;
1703 if (HeKLEN(entry) != len)
1704 continue;
1c846c1f 1705 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 1706 continue;
c3654f1a
IH
1707 if (HeKUTF8(entry) != (char)is_utf8)
1708 continue;
fde52b5c 1709 found = 1;
fde52b5c
PP
1710 break;
1711 }
bbce6d69 1712 if (!found) {
d33b2eba 1713 entry = new_HE();
c3654f1a 1714 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
bbce6d69
PP
1715 HeVAL(entry) = Nullsv;
1716 HeNEXT(entry) = *oentry;
1717 *oentry = entry;
cbec9347 1718 xhv->xhv_keys++; /* HvKEYS(hv)++ */
bbce6d69 1719 if (i) { /* initial entry? */
cbec9347
JH
1720 xhv->xhv_fill++; /* HvFILL(hv)++ */
1721 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
1722 hsplit(PL_strtab);
bbce6d69
PP
1723 }
1724 }
1725
1726 ++HeVAL(entry); /* use value slot as REFCNT */
5f08fbcd 1727 UNLOCK_STRTAB_MUTEX;
f9a63242
JH
1728 if (str != save)
1729 Safefree(str);
ff68c719 1730 return HeKEY_hek(entry);
fde52b5c 1731}