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