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