3 * Copyright (c) 1991-2002, Larry Wall
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.
11 * "I sit beside the fire and think of all that I have seen." --Bilbo
15 =head1 Hash Manipulation Functions
30 PL_he_root = HeNEXT(he);
39 HeNEXT(p) = (HE*)PL_he_root;
50 New(54, ptr, 1008/sizeof(XPV), XPV);
51 ptr->xpv_pv = (char*)PL_he_arenaroot;
52 PL_he_arenaroot = ptr;
55 heend = &he[1008 / sizeof(HE) - 1];
58 HeNEXT(he) = (HE*)(he + 1);
66 #define new_HE() (HE*)safemalloc(sizeof(HE))
67 #define del_HE(p) safefree((char*)p)
71 #define new_HE() new_he()
72 #define del_HE(p) del_he(p)
77 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
82 New(54, k, HEK_BASESIZE + len + 2, char);
84 Copy(str, HEK_KEY(hek), len, char);
85 HEK_KEY(hek)[len] = 0;
88 HEK_FLAGS(hek) = (unsigned char)flags;
92 #if defined(USE_ITHREADS)
94 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
100 /* look for it in the table first */
101 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
105 /* create anew and remember what it is */
107 ptr_table_store(PL_ptr_table, e, ret);
109 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
110 if (HeKLEN(e) == HEf_SVKEY)
111 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
113 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
116 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
118 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
121 #endif /* USE_ITHREADS */
124 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
127 SV *sv = sv_newmortal(), *esv = sv_newmortal();
128 if (!(flags & HVhek_FREEKEY)) {
129 sv_setpvn(sv, key, klen);
132 /* Need to free saved eventually assign to mortal SV */
133 SV *sv = sv_newmortal();
134 sv_usepvn(sv, (char *) key, klen);
136 if (flags & HVhek_UTF8) {
139 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
140 Perl_croak(aTHX_ SvPVX(esv), sv);
143 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
149 Returns the SV which corresponds to the specified key in the hash. The
150 C<klen> is the length of the key. If C<lval> is set then the fetch will be
151 part of a store. Check that the return value is non-null before
152 dereferencing it to an C<SV*>.
154 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
155 information on how to use this function on tied hashes.
162 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
164 bool is_utf8 = FALSE;
165 const char *keysave = key;
174 STRLEN tmplen = klen;
175 /* Just casting the &klen to (STRLEN) won't work well
176 * if STRLEN and I32 are of different widths. --jhi */
177 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
179 /* If we were able to downgrade here, then than means that we were
180 passed in a key which only had chars 0-255, but was utf8 encoded. */
183 /* If we found we were able to downgrade the string to bytes, then
184 we should flag that it needs upgrading on keys or each. */
186 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
189 return hv_fetch_flags (hv, key, klen, lval, flags);
193 S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
203 if (SvRMAGICAL(hv)) {
204 /* All this clause seems to be utf8 unaware.
205 By moving the utf8 stuff out to hv_fetch_flags I need to ensure
206 key doesn't leak. I've not tried solving the utf8-ness.
209 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
211 mg_copy((SV*)hv, sv, key, klen);
212 if (flags & HVhek_FREEKEY)
215 return &PL_hv_fetch_sv;
217 #ifdef ENV_IS_CASELESS
218 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
220 for (i = 0; i < klen; ++i)
221 if (isLOWER(key[i])) {
222 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
223 SV **ret = hv_fetch(hv, nkey, klen, 0);
225 ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
227 } else if (flags & HVhek_FREEKEY)
235 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
236 avoid unnecessary pointer dereferencing. */
237 xhv = (XPVHV*)SvANY(hv);
238 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
240 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
241 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
244 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
245 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
248 if (flags & HVhek_FREEKEY)
254 PERL_HASH(hash, key, klen);
256 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
257 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
258 for (; entry; entry = HeNEXT(entry)) {
259 if (HeHASH(entry) != hash) /* strings can't be equal */
261 if (HeKLEN(entry) != (I32)klen)
263 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
265 /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
266 flags is 1 if utf8. need HeKFLAGS(entry) also 1.
267 xor is true if bits differ, in which case this isn't a match. */
268 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
270 if (lval && HeKFLAGS(entry) != flags) {
271 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
272 But if entry was set previously with HVhek_WASUTF8 and key now
273 doesn't (or vice versa) then we should change the key's flag,
274 as this is assignment. */
275 if (HvSHAREKEYS(hv)) {
276 /* Need to swap the key we have for a key with the flags we
277 need. As keys are shared we can't just write to the flag,
278 so we share the new one, unshare the old one. */
279 int flags_nofree = flags & ~HVhek_FREEKEY;
280 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
281 unshare_hek (HeKEY_hek(entry));
282 HeKEY_hek(entry) = new_hek;
285 HeKFLAGS(entry) = flags;
287 if (flags & HVhek_FREEKEY)
289 /* if we find a placeholder, we pretend we haven't found anything */
290 if (HeVAL(entry) == &PL_sv_undef)
292 return &HeVAL(entry);
295 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
296 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
298 char *env = PerlEnv_ENVgetenv_len(key,&len);
300 sv = newSVpvn(env,len);
302 if (flags & HVhek_FREEKEY)
304 return hv_store(hv,key,klen,sv,hash);
308 if (!entry && SvREADONLY(hv)) {
309 S_hv_notallowed(aTHX_ flags, key, klen,
310 "access disallowed key '%"SVf"' in"
313 if (lval) { /* gonna assign to this, so it better be there */
315 return hv_store_flags(hv,key,klen,sv,hash,flags);
317 if (flags & HVhek_FREEKEY)
322 /* returns an HE * structure with the all fields set */
323 /* note that hent_val will be a mortal sv for MAGICAL hashes */
325 =for apidoc hv_fetch_ent
327 Returns the hash entry which corresponds to the specified key in the hash.
328 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
329 if you want the function to compute it. IF C<lval> is set then the fetch
330 will be part of a store. Make sure the return value is non-null before
331 accessing it. The return value when C<tb> is a tied hash is a pointer to a
332 static location, so be sure to make a copy of the structure if you need to
335 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
336 information on how to use this function on tied hashes.
342 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
356 if (SvRMAGICAL(hv)) {
357 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
359 keysv = sv_2mortal(newSVsv(keysv));
360 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
361 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
363 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
364 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
366 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
367 HeVAL(&PL_hv_fetch_ent_mh) = sv;
368 return &PL_hv_fetch_ent_mh;
370 #ifdef ENV_IS_CASELESS
371 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
373 key = SvPV(keysv, klen);
374 for (i = 0; i < klen; ++i)
375 if (isLOWER(key[i])) {
376 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
377 (void)strupr(SvPVX(nkeysv));
378 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
380 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
387 xhv = (XPVHV*)SvANY(hv);
388 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
390 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
391 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
394 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
395 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
401 keysave = key = SvPV(keysv, klen);
402 is_utf8 = (SvUTF8(keysv)!=0);
405 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
409 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
413 if SvIsCOW_shared_hash(keysv) {
416 PERL_HASH(hash, key, klen);
420 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
421 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
422 for (; entry; entry = HeNEXT(entry)) {
423 if (HeHASH(entry) != hash) /* strings can't be equal */
425 if (HeKLEN(entry) != (I32)klen)
427 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
429 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
431 if (lval && HeKFLAGS(entry) != flags) {
432 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
433 But if entry was set previously with HVhek_WASUTF8 and key now
434 doesn't (or vice versa) then we should change the key's flag,
435 as this is assignment. */
436 if (HvSHAREKEYS(hv)) {
437 /* Need to swap the key we have for a key with the flags we
438 need. As keys are shared we can't just write to the flag,
439 so we share the new one, unshare the old one. */
440 int flags_nofree = flags & ~HVhek_FREEKEY;
441 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
442 unshare_hek (HeKEY_hek(entry));
443 HeKEY_hek(entry) = new_hek;
446 HeKFLAGS(entry) = flags;
450 /* if we find a placeholder, we pretend we haven't found anything */
451 if (HeVAL(entry) == &PL_sv_undef)
455 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
456 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
458 char *env = PerlEnv_ENVgetenv_len(key,&len);
460 sv = newSVpvn(env,len);
462 return hv_store_ent(hv,keysv,sv,hash);
466 if (!entry && SvREADONLY(hv)) {
467 S_hv_notallowed(aTHX_ flags, key, klen,
468 "access disallowed key '%"SVf"' in"
471 if (flags & HVhek_FREEKEY)
473 if (lval) { /* gonna assign to this, so it better be there */
475 return hv_store_ent(hv,keysv,sv,hash);
481 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
483 MAGIC *mg = SvMAGIC(hv);
487 if (isUPPER(mg->mg_type)) {
489 switch (mg->mg_type) {
490 case PERL_MAGIC_tied:
492 *needs_store = FALSE;
495 mg = mg->mg_moremagic;
502 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
503 the length of the key. The C<hash> parameter is the precomputed hash
504 value; if it is zero then Perl will compute it. The return value will be
505 NULL if the operation failed or if the value did not need to be actually
506 stored within the hash (as in the case of tied hashes). Otherwise it can
507 be dereferenced to get the original C<SV*>. Note that the caller is
508 responsible for suitably incrementing the reference count of C<val> before
509 the call, and decrementing it if the function returned NULL. Effectively
510 a successful hv_store takes ownership of one reference to C<val>. This is
511 usually what you want; a newly created SV has a reference count of one, so
512 if all your code does is create SVs then store them in a hash, hv_store
513 will own the only reference to the new SV, and your code doesn't need to do
514 anything further to tidy up. hv_store is not implemented as a call to
515 hv_store_ent, and does not create a temporary SV for the key, so if your
516 key data is not already in SV form then use hv_store in preference to
519 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
520 information on how to use this function on tied hashes.
526 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
528 bool is_utf8 = FALSE;
529 const char *keysave = key;
538 STRLEN tmplen = klen;
539 /* Just casting the &klen to (STRLEN) won't work well
540 * if STRLEN and I32 are of different widths. --jhi */
541 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
543 /* If we were able to downgrade here, then than means that we were
544 passed in a key which only had chars 0-255, but was utf8 encoded. */
547 /* If we found we were able to downgrade the string to bytes, then
548 we should flag that it needs upgrading on keys or each. */
550 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
553 return hv_store_flags (hv, key, klen, val, hash, flags);
557 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
558 register U32 hash, int flags)
563 register HE **oentry;
568 xhv = (XPVHV*)SvANY(hv);
572 hv_magic_check (hv, &needs_copy, &needs_store);
574 mg_copy((SV*)hv, val, key, klen);
575 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
576 if (flags & HVhek_FREEKEY)
580 #ifdef ENV_IS_CASELESS
581 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
582 key = savepvn(key,klen);
583 key = (const char*)strupr((char*)key);
591 HvHASKFLAGS_on((SV*)hv);
594 PERL_HASH(hash, key, klen);
596 if (!xhv->xhv_array /* !HvARRAY(hv) */)
597 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
598 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
601 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
602 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
605 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
606 if (HeHASH(entry) != hash) /* strings can't be equal */
608 if (HeKLEN(entry) != (I32)klen)
610 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
612 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
614 if (HeVAL(entry) == &PL_sv_undef)
615 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
617 SvREFCNT_dec(HeVAL(entry));
618 if (flags & HVhek_PLACEHOLD) {
619 /* We have been requested to insert a placeholder. Currently
620 only Storable is allowed to do this. */
621 xhv->xhv_placeholders++;
622 HeVAL(entry) = &PL_sv_undef;
626 if (HeKFLAGS(entry) != flags) {
627 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
628 But if entry was set previously with HVhek_WASUTF8 and key now
629 doesn't (or vice versa) then we should change the key's flag,
630 as this is assignment. */
631 if (HvSHAREKEYS(hv)) {
632 /* Need to swap the key we have for a key with the flags we
633 need. As keys are shared we can't just write to the flag,
634 so we share the new one, unshare the old one. */
635 int flags_nofree = flags & ~HVhek_FREEKEY;
636 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
637 unshare_hek (HeKEY_hek(entry));
638 HeKEY_hek(entry) = new_hek;
641 HeKFLAGS(entry) = flags;
643 if (flags & HVhek_FREEKEY)
645 return &HeVAL(entry);
648 if (SvREADONLY(hv)) {
649 S_hv_notallowed(aTHX_ flags, key, klen,
650 "access disallowed key '%"SVf"' to"
655 /* share_hek_flags will do the free for us. This might be considered
658 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
659 else /* gotta do the real thing */
660 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
661 if (flags & HVhek_PLACEHOLD) {
662 /* We have been requested to insert a placeholder. Currently
663 only Storable is allowed to do this. */
664 xhv->xhv_placeholders++;
665 HeVAL(entry) = &PL_sv_undef;
668 HeNEXT(entry) = *oentry;
671 xhv->xhv_keys++; /* HvKEYS(hv)++ */
672 if (i) { /* initial entry? */
673 xhv->xhv_fill++; /* HvFILL(hv)++ */
674 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
678 return &HeVAL(entry);
682 =for apidoc hv_store_ent
684 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
685 parameter is the precomputed hash value; if it is zero then Perl will
686 compute it. The return value is the new hash entry so created. It will be
687 NULL if the operation failed or if the value did not need to be actually
688 stored within the hash (as in the case of tied hashes). Otherwise the
689 contents of the return value can be accessed using the C<He?> macros
690 described here. Note that the caller is responsible for suitably
691 incrementing the reference count of C<val> before the call, and
692 decrementing it if the function returned NULL. Effectively a successful
693 hv_store_ent takes ownership of one reference to C<val>. This is
694 usually what you want; a newly created SV has a reference count of one, so
695 if all your code does is create SVs then store them in a hash, hv_store
696 will own the only reference to the new SV, and your code doesn't need to do
697 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
698 unlike C<val> it does not take ownership of it, so maintaining the correct
699 reference count on C<key> is entirely the caller's responsibility. hv_store
700 is not implemented as a call to hv_store_ent, and does not create a temporary
701 SV for the key, so if your key data is not already in SV form then use
702 hv_store in preference to hv_store_ent.
704 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
705 information on how to use this function on tied hashes.
711 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
726 xhv = (XPVHV*)SvANY(hv);
730 hv_magic_check (hv, &needs_copy, &needs_store);
732 bool save_taint = PL_tainted;
734 PL_tainted = SvTAINTED(keysv);
735 keysv = sv_2mortal(newSVsv(keysv));
736 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
737 TAINT_IF(save_taint);
738 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
740 #ifdef ENV_IS_CASELESS
741 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
742 key = SvPV(keysv, klen);
743 keysv = sv_2mortal(newSVpvn(key,klen));
744 (void)strupr(SvPVX(keysv));
751 keysave = key = SvPV(keysv, klen);
752 is_utf8 = (SvUTF8(keysv) != 0);
755 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
759 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
760 HvHASKFLAGS_on((SV*)hv);
764 if SvIsCOW_shared_hash(keysv) {
767 PERL_HASH(hash, key, klen);
771 if (!xhv->xhv_array /* !HvARRAY(hv) */)
772 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
773 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
776 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
777 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
780 for (; entry; i=0, entry = HeNEXT(entry)) {
781 if (HeHASH(entry) != hash) /* strings can't be equal */
783 if (HeKLEN(entry) != (I32)klen)
785 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
787 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
789 if (HeVAL(entry) == &PL_sv_undef)
790 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
792 SvREFCNT_dec(HeVAL(entry));
794 if (HeKFLAGS(entry) != flags) {
795 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
796 But if entry was set previously with HVhek_WASUTF8 and key now
797 doesn't (or vice versa) then we should change the key's flag,
798 as this is assignment. */
799 if (HvSHAREKEYS(hv)) {
800 /* Need to swap the key we have for a key with the flags we
801 need. As keys are shared we can't just write to the flag,
802 so we share the new one, unshare the old one. */
803 int flags_nofree = flags & ~HVhek_FREEKEY;
804 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
805 unshare_hek (HeKEY_hek(entry));
806 HeKEY_hek(entry) = new_hek;
809 HeKFLAGS(entry) = flags;
811 if (flags & HVhek_FREEKEY)
816 if (SvREADONLY(hv)) {
817 S_hv_notallowed(aTHX_ flags, key, klen,
818 "access disallowed key '%"SVf"' to"
823 /* share_hek_flags will do the free for us. This might be considered
826 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
827 else /* gotta do the real thing */
828 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
830 HeNEXT(entry) = *oentry;
833 xhv->xhv_keys++; /* HvKEYS(hv)++ */
834 if (i) { /* initial entry? */
835 xhv->xhv_fill++; /* HvFILL(hv)++ */
836 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
844 =for apidoc hv_delete
846 Deletes a key/value pair in the hash. The value SV is removed from the
847 hash and returned to the caller. The C<klen> is the length of the key.
848 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
855 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
861 register HE **oentry;
864 bool is_utf8 = FALSE;
866 const char *keysave = key;
874 if (SvRMAGICAL(hv)) {
877 hv_magic_check (hv, &needs_copy, &needs_store);
879 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
883 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
884 /* No longer an element */
885 sv_unmagic(sv, PERL_MAGIC_tiedelem);
888 return Nullsv; /* element cannot be deleted */
890 #ifdef ENV_IS_CASELESS
891 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
892 sv = sv_2mortal(newSVpvn(key,klen));
893 key = strupr(SvPVX(sv));
898 xhv = (XPVHV*)SvANY(hv);
899 if (!xhv->xhv_array /* !HvARRAY(hv) */)
903 STRLEN tmplen = klen;
904 /* See the note in hv_fetch(). --jhi */
905 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
908 k_flags = HVhek_UTF8;
910 k_flags |= HVhek_FREEKEY;
913 PERL_HASH(hash, key, klen);
915 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
916 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
919 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
920 if (HeHASH(entry) != hash) /* strings can't be equal */
922 if (HeKLEN(entry) != (I32)klen)
924 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
926 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
928 if (k_flags & HVhek_FREEKEY)
930 /* if placeholder is here, it's already been deleted.... */
931 if (HeVAL(entry) == &PL_sv_undef)
934 return Nullsv; /* if still SvREADONLY, leave it deleted. */
936 /* okay, really delete the placeholder... */
937 *oentry = HeNEXT(entry);
939 xhv->xhv_fill--; /* HvFILL(hv)-- */
940 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
943 hv_free_ent(hv, entry);
944 xhv->xhv_keys--; /* HvKEYS(hv)-- */
945 if (xhv->xhv_keys == 0)
947 xhv->xhv_placeholders--;
951 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
952 S_hv_notallowed(aTHX_ k_flags, key, klen,
953 "delete readonly key '%"SVf"' from"
957 if (flags & G_DISCARD)
960 sv = sv_2mortal(HeVAL(entry));
961 HeVAL(entry) = &PL_sv_undef;
965 * If a restricted hash, rather than really deleting the entry, put
966 * a placeholder there. This marks the key as being "approved", so
967 * we can still access via not-really-existing key without raising
970 if (SvREADONLY(hv)) {
971 HeVAL(entry) = &PL_sv_undef;
972 /* We'll be saving this slot, so the number of allocated keys
973 * doesn't go down, but the number placeholders goes up */
974 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
976 *oentry = HeNEXT(entry);
978 xhv->xhv_fill--; /* HvFILL(hv)-- */
979 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
982 hv_free_ent(hv, entry);
983 xhv->xhv_keys--; /* HvKEYS(hv)-- */
984 if (xhv->xhv_keys == 0)
989 if (SvREADONLY(hv)) {
990 S_hv_notallowed(aTHX_ k_flags, key, klen,
991 "access disallowed key '%"SVf"' from"
995 if (k_flags & HVhek_FREEKEY)
1001 =for apidoc hv_delete_ent
1003 Deletes a key/value pair in the hash. The value SV is removed from the
1004 hash and returned to the caller. The C<flags> value will normally be zero;
1005 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
1006 precomputed hash value, or 0 to ask for it to be computed.
1012 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1014 register XPVHV* xhv;
1019 register HE **oentry;
1027 if (SvRMAGICAL(hv)) {
1030 hv_magic_check (hv, &needs_copy, &needs_store);
1032 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
1036 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1037 /* No longer an element */
1038 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1041 return Nullsv; /* element cannot be deleted */
1043 #ifdef ENV_IS_CASELESS
1044 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1045 key = SvPV(keysv, klen);
1046 keysv = sv_2mortal(newSVpvn(key,klen));
1047 (void)strupr(SvPVX(keysv));
1053 xhv = (XPVHV*)SvANY(hv);
1054 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1057 keysave = key = SvPV(keysv, klen);
1058 is_utf8 = (SvUTF8(keysv) != 0);
1061 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1063 k_flags = HVhek_UTF8;
1065 k_flags |= HVhek_FREEKEY;
1069 PERL_HASH(hash, key, klen);
1071 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1072 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1075 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1076 if (HeHASH(entry) != hash) /* strings can't be equal */
1078 if (HeKLEN(entry) != (I32)klen)
1080 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1082 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1084 if (k_flags & HVhek_FREEKEY)
1087 /* if placeholder is here, it's already been deleted.... */
1088 if (HeVAL(entry) == &PL_sv_undef)
1091 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1093 /* okay, really delete the placeholder. */
1094 *oentry = HeNEXT(entry);
1096 xhv->xhv_fill--; /* HvFILL(hv)-- */
1097 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1100 hv_free_ent(hv, entry);
1101 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1102 if (xhv->xhv_keys == 0)
1103 HvHASKFLAGS_off(hv);
1104 xhv->xhv_placeholders--;
1107 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1108 S_hv_notallowed(aTHX_ k_flags, key, klen,
1109 "delete readonly key '%"SVf"' from"
1113 if (flags & G_DISCARD)
1116 sv = sv_2mortal(HeVAL(entry));
1117 HeVAL(entry) = &PL_sv_undef;
1121 * If a restricted hash, rather than really deleting the entry, put
1122 * a placeholder there. This marks the key as being "approved", so
1123 * we can still access via not-really-existing key without raising
1126 if (SvREADONLY(hv)) {
1127 HeVAL(entry) = &PL_sv_undef;
1128 /* We'll be saving this slot, so the number of allocated keys
1129 * doesn't go down, but the number placeholders goes up */
1130 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1132 *oentry = HeNEXT(entry);
1134 xhv->xhv_fill--; /* HvFILL(hv)-- */
1135 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1138 hv_free_ent(hv, entry);
1139 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1140 if (xhv->xhv_keys == 0)
1141 HvHASKFLAGS_off(hv);
1145 if (SvREADONLY(hv)) {
1146 S_hv_notallowed(aTHX_ k_flags, key, klen,
1147 "delete disallowed key '%"SVf"' from"
1151 if (k_flags & HVhek_FREEKEY)
1157 =for apidoc hv_exists
1159 Returns a boolean indicating whether the specified hash key exists. The
1160 C<klen> is the length of the key.
1166 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1168 register XPVHV* xhv;
1172 bool is_utf8 = FALSE;
1173 const char *keysave = key;
1184 if (SvRMAGICAL(hv)) {
1185 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1186 sv = sv_newmortal();
1187 mg_copy((SV*)hv, sv, key, klen);
1188 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1189 return (bool)SvTRUE(sv);
1191 #ifdef ENV_IS_CASELESS
1192 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1193 sv = sv_2mortal(newSVpvn(key,klen));
1194 key = strupr(SvPVX(sv));
1199 xhv = (XPVHV*)SvANY(hv);
1200 #ifndef DYNAMIC_ENV_FETCH
1201 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1206 STRLEN tmplen = klen;
1207 /* See the note in hv_fetch(). --jhi */
1208 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1211 k_flags = HVhek_UTF8;
1213 k_flags |= HVhek_FREEKEY;
1216 PERL_HASH(hash, key, klen);
1218 #ifdef DYNAMIC_ENV_FETCH
1219 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1222 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1223 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1224 for (; entry; entry = HeNEXT(entry)) {
1225 if (HeHASH(entry) != hash) /* strings can't be equal */
1227 if (HeKLEN(entry) != klen)
1229 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1231 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1233 if (k_flags & HVhek_FREEKEY)
1235 /* If we find the key, but the value is a placeholder, return false. */
1236 if (HeVAL(entry) == &PL_sv_undef)
1241 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1242 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1244 char *env = PerlEnv_ENVgetenv_len(key,&len);
1246 sv = newSVpvn(env,len);
1248 (void)hv_store(hv,key,klen,sv,hash);
1249 if (k_flags & HVhek_FREEKEY)
1255 if (k_flags & HVhek_FREEKEY)
1262 =for apidoc hv_exists_ent
1264 Returns a boolean indicating whether the specified hash key exists. C<hash>
1265 can be a valid precomputed hash value, or 0 to ask for it to be
1272 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1274 register XPVHV* xhv;
1286 if (SvRMAGICAL(hv)) {
1287 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1288 SV* svret = sv_newmortal();
1289 sv = sv_newmortal();
1290 keysv = sv_2mortal(newSVsv(keysv));
1291 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1292 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1293 return (bool)SvTRUE(svret);
1295 #ifdef ENV_IS_CASELESS
1296 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1297 key = SvPV(keysv, klen);
1298 keysv = sv_2mortal(newSVpvn(key,klen));
1299 (void)strupr(SvPVX(keysv));
1305 xhv = (XPVHV*)SvANY(hv);
1306 #ifndef DYNAMIC_ENV_FETCH
1307 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1311 keysave = key = SvPV(keysv, klen);
1312 is_utf8 = (SvUTF8(keysv) != 0);
1314 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1316 k_flags = HVhek_UTF8;
1318 k_flags |= HVhek_FREEKEY;
1321 PERL_HASH(hash, key, klen);
1323 #ifdef DYNAMIC_ENV_FETCH
1324 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1327 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1328 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1329 for (; entry; entry = HeNEXT(entry)) {
1330 if (HeHASH(entry) != hash) /* strings can't be equal */
1332 if (HeKLEN(entry) != (I32)klen)
1334 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1336 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1338 if (k_flags & HVhek_FREEKEY)
1340 /* If we find the key, but the value is a placeholder, return false. */
1341 if (HeVAL(entry) == &PL_sv_undef)
1345 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1346 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1348 char *env = PerlEnv_ENVgetenv_len(key,&len);
1350 sv = newSVpvn(env,len);
1352 (void)hv_store_ent(hv,keysv,sv,hash);
1353 if (k_flags & HVhek_FREEKEY)
1359 if (k_flags & HVhek_FREEKEY)
1365 S_hsplit(pTHX_ HV *hv)
1367 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1368 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1369 register I32 newsize = oldsize * 2;
1371 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1375 register HE **oentry;
1378 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1379 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1385 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1390 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1391 if (oldsize >= 64) {
1392 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1393 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1396 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1400 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1401 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1402 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1405 for (i=0; i<oldsize; i++,aep++) {
1406 if (!*aep) /* non-existent */
1409 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1410 if ((HeHASH(entry) & newsize) != (U32)i) {
1411 *oentry = HeNEXT(entry);
1412 HeNEXT(entry) = *bep;
1414 xhv->xhv_fill++; /* HvFILL(hv)++ */
1419 oentry = &HeNEXT(entry);
1421 if (!*aep) /* everything moved */
1422 xhv->xhv_fill--; /* HvFILL(hv)-- */
1427 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1429 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1430 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1431 register I32 newsize;
1437 register HE **oentry;
1439 newsize = (I32) newmax; /* possible truncation here */
1440 if (newsize != newmax || newmax <= oldsize)
1442 while ((newsize & (1 + ~newsize)) != newsize) {
1443 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1445 if (newsize < newmax)
1447 if (newsize < newmax)
1448 return; /* overflow detection */
1450 a = xhv->xhv_array; /* HvARRAY(hv) */
1453 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1454 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1460 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1465 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1466 if (oldsize >= 64) {
1467 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1468 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1471 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1474 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1477 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1479 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1480 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1481 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1485 for (i=0; i<oldsize; i++,aep++) {
1486 if (!*aep) /* non-existent */
1488 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1489 if ((j = (HeHASH(entry) & newsize)) != i) {
1491 *oentry = HeNEXT(entry);
1492 if (!(HeNEXT(entry) = aep[j]))
1493 xhv->xhv_fill++; /* HvFILL(hv)++ */
1498 oentry = &HeNEXT(entry);
1500 if (!*aep) /* everything moved */
1501 xhv->xhv_fill--; /* HvFILL(hv)-- */
1508 Creates a new HV. The reference count is set to 1.
1517 register XPVHV* xhv;
1519 hv = (HV*)NEWSV(502,0);
1520 sv_upgrade((SV *)hv, SVt_PVHV);
1521 xhv = (XPVHV*)SvANY(hv);
1524 #ifndef NODEFAULT_SHAREKEYS
1525 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1527 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1528 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1529 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1530 (void)hv_iterinit(hv); /* so each() will start off right */
1535 Perl_newHVhv(pTHX_ HV *ohv)
1538 STRLEN hv_max, hv_fill;
1540 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1542 hv_max = HvMAX(ohv);
1544 if (!SvMAGICAL((SV *)ohv)) {
1545 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1547 bool shared = !!HvSHAREKEYS(ohv);
1548 HE **ents, **oents = (HE **)HvARRAY(ohv);
1550 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1553 /* In each bucket... */
1554 for (i = 0; i <= hv_max; i++) {
1555 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1562 /* Copy the linked list of entries. */
1563 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1564 U32 hash = HeHASH(oent);
1565 char *key = HeKEY(oent);
1566 STRLEN len = HeKLEN(oent);
1567 int flags = HeKFLAGS(oent);
1570 HeVAL(ent) = newSVsv(HeVAL(oent));
1572 = shared ? share_hek_flags(key, len, hash, flags)
1573 : save_hek_flags(key, len, hash, flags);
1584 HvFILL(hv) = hv_fill;
1585 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1589 /* Iterate over ohv, copying keys and values one at a time. */
1591 I32 riter = HvRITER(ohv);
1592 HE *eiter = HvEITER(ohv);
1594 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1595 while (hv_max && hv_max + 1 >= hv_fill * 2)
1596 hv_max = hv_max / 2;
1600 while ((entry = hv_iternext_flags(ohv, 0))) {
1601 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1602 newSVsv(HeVAL(entry)), HeHASH(entry),
1605 HvRITER(ohv) = riter;
1606 HvEITER(ohv) = eiter;
1613 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1620 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1621 PL_sub_generation++; /* may be deletion of method from stash */
1623 if (HeKLEN(entry) == HEf_SVKEY) {
1624 SvREFCNT_dec(HeKEY_sv(entry));
1625 Safefree(HeKEY_hek(entry));
1627 else if (HvSHAREKEYS(hv))
1628 unshare_hek(HeKEY_hek(entry));
1630 Safefree(HeKEY_hek(entry));
1635 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1639 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1640 PL_sub_generation++; /* may be deletion of method from stash */
1641 sv_2mortal(HeVAL(entry)); /* free between statements */
1642 if (HeKLEN(entry) == HEf_SVKEY) {
1643 sv_2mortal(HeKEY_sv(entry));
1644 Safefree(HeKEY_hek(entry));
1646 else if (HvSHAREKEYS(hv))
1647 unshare_hek(HeKEY_hek(entry));
1649 Safefree(HeKEY_hek(entry));
1654 =for apidoc hv_clear
1656 Clears a hash, making it empty.
1662 Perl_hv_clear(pTHX_ HV *hv)
1664 register XPVHV* xhv;
1668 if(SvREADONLY(hv)) {
1669 Perl_croak(aTHX_ "Attempt to clear a restricted hash");
1672 xhv = (XPVHV*)SvANY(hv);
1674 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1675 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1676 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1677 if (xhv->xhv_array /* HvARRAY(hv) */)
1678 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1679 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1684 HvHASKFLAGS_off(hv);
1688 S_hfreeentries(pTHX_ HV *hv)
1690 register HE **array;
1692 register HE *oentry = Null(HE*);
1703 array = HvARRAY(hv);
1708 entry = HeNEXT(entry);
1709 hv_free_ent(hv, oentry);
1714 entry = array[riter];
1717 (void)hv_iterinit(hv);
1721 =for apidoc hv_undef
1729 Perl_hv_undef(pTHX_ HV *hv)
1731 register XPVHV* xhv;
1734 xhv = (XPVHV*)SvANY(hv);
1736 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1738 Safefree(HvNAME(hv));
1741 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1742 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1743 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1744 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1745 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1752 =for apidoc hv_iterinit
1754 Prepares a starting point to traverse a hash table. Returns the number of
1755 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1756 currently only meaningful for hashes without tie magic.
1758 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1759 hash buckets that happen to be in use. If you still need that esoteric
1760 value, you can get it through the macro C<HvFILL(tb)>.
1767 Perl_hv_iterinit(pTHX_ HV *hv)
1769 register XPVHV* xhv;
1773 Perl_croak(aTHX_ "Bad hash");
1774 xhv = (XPVHV*)SvANY(hv);
1775 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1776 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1778 hv_free_ent(hv, entry);
1780 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1781 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1782 /* used to be xhv->xhv_fill before 5.004_65 */
1783 return XHvTOTALKEYS(xhv);
1786 =for apidoc hv_iternext
1788 Returns entries from a hash iterator. See C<hv_iterinit>.
1790 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1791 iterator currently points to, without losing your place or invalidating your
1792 iterator. Note that in this case the current entry is deleted from the hash
1793 with your iterator holding the last reference to it. Your iterator is flagged
1794 to free the entry on the next call to C<hv_iternext>, so you must not discard
1795 your iterator immediately else the entry will leak - call C<hv_iternext> to
1796 trigger the resource deallocation.
1802 Perl_hv_iternext(pTHX_ HV *hv)
1804 return hv_iternext_flags(hv, 0);
1808 =for apidoc hv_iternext_flags
1810 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1811 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1812 set the placeholders keys (for restricted hashes) will be returned in addition
1813 to normal keys. By default placeholders are automatically skipped over.
1814 Currently a placeholder is implemented with a value that is literally
1815 <&Perl_sv_undef> (a regular C<undef> value is a normal read-write SV for which
1816 C<!SvOK> is false). Note that the implementation of placeholders and
1817 restricted hashes may change, and the implementation currently is
1818 insufficiently abstracted for any change to be tidy.
1824 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1826 register XPVHV* xhv;
1832 Perl_croak(aTHX_ "Bad hash");
1833 xhv = (XPVHV*)SvANY(hv);
1834 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1836 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1837 SV *key = sv_newmortal();
1839 sv_setsv(key, HeSVKEY_force(entry));
1840 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1846 /* one HE per MAGICAL hash */
1847 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1849 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1851 HeKEY_hek(entry) = hek;
1852 HeKLEN(entry) = HEf_SVKEY;
1854 magic_nextpack((SV*) hv,mg,key);
1856 /* force key to stay around until next time */
1857 HeSVKEY_set(entry, SvREFCNT_inc(key));
1858 return entry; /* beware, hent_val is not set */
1861 SvREFCNT_dec(HeVAL(entry));
1862 Safefree(HeKEY_hek(entry));
1864 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1867 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1868 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1872 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1873 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1874 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1876 /* At start of hash, entry is NULL. */
1879 entry = HeNEXT(entry);
1880 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1882 * Skip past any placeholders -- don't want to include them in
1885 while (entry && HeVAL(entry) == &PL_sv_undef) {
1886 entry = HeNEXT(entry);
1891 /* OK. Come to the end of the current list. Grab the next one. */
1893 xhv->xhv_riter++; /* HvRITER(hv)++ */
1894 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1895 /* There is no next one. End of the hash. */
1896 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1899 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1900 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1902 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1903 /* If we have an entry, but it's a placeholder, don't count it.
1905 while (entry && HeVAL(entry) == &PL_sv_undef)
1906 entry = HeNEXT(entry);
1908 /* Will loop again if this linked list starts NULL
1909 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1910 or if we run through it and find only placeholders. */
1913 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1915 hv_free_ent(hv, oldentry);
1918 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1923 =for apidoc hv_iterkey
1925 Returns the key from the current position of the hash iterator. See
1932 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1934 if (HeKLEN(entry) == HEf_SVKEY) {
1936 char *p = SvPV(HeKEY_sv(entry), len);
1941 *retlen = HeKLEN(entry);
1942 return HeKEY(entry);
1946 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1948 =for apidoc hv_iterkeysv
1950 Returns the key as an C<SV*> from the current position of the hash
1951 iterator. The return value will always be a mortal copy of the key. Also
1958 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1960 if (HeKLEN(entry) != HEf_SVKEY) {
1961 HEK *hek = HeKEY_hek(entry);
1962 int flags = HEK_FLAGS(hek);
1965 if (flags & HVhek_WASUTF8) {
1967 Andreas would like keys he put in as utf8 to come back as utf8
1969 STRLEN utf8_len = HEK_LEN(hek);
1970 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1972 sv = newSVpvn ((char*)as_utf8, utf8_len);
1974 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1976 sv = newSVpvn_share(HEK_KEY(hek),
1977 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1980 return sv_2mortal(sv);
1982 return sv_mortalcopy(HeKEY_sv(entry));
1986 =for apidoc hv_iterval
1988 Returns the value from the current position of the hash iterator. See
1995 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1997 if (SvRMAGICAL(hv)) {
1998 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1999 SV* sv = sv_newmortal();
2000 if (HeKLEN(entry) == HEf_SVKEY)
2001 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2002 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2006 return HeVAL(entry);
2010 =for apidoc hv_iternextsv
2012 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2019 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2022 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2024 *key = hv_iterkey(he, retlen);
2025 return hv_iterval(hv, he);
2029 =for apidoc hv_magic
2031 Adds magic to a hash. See C<sv_magic>.
2037 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2039 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2042 #if 0 /* use the macro from hv.h instead */
2045 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2047 return HEK_KEY(share_hek(sv, len, hash));
2052 /* possibly free a shared string if no one has access to it
2053 * len and hash must both be valid for str.
2056 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2058 unshare_hek_or_pvn (NULL, str, len, hash);
2063 Perl_unshare_hek(pTHX_ HEK *hek)
2065 unshare_hek_or_pvn(hek, NULL, 0, 0);
2068 /* possibly free a shared string if no one has access to it
2069 hek if non-NULL takes priority over the other 3, else str, len and hash
2070 are used. If so, len and hash must both be valid for str.
2073 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2075 register XPVHV* xhv;
2077 register HE **oentry;
2080 bool is_utf8 = FALSE;
2082 const char *save = str;
2085 hash = HEK_HASH(hek);
2086 } else if (len < 0) {
2087 STRLEN tmplen = -len;
2089 /* See the note in hv_fetch(). --jhi */
2090 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2093 k_flags = HVhek_UTF8;
2095 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2098 /* what follows is the moral equivalent of:
2099 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2100 if (--*Svp == Nullsv)
2101 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2103 xhv = (XPVHV*)SvANY(PL_strtab);
2104 /* assert(xhv_array != 0) */
2106 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2107 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2109 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2110 if (HeKEY_hek(entry) != hek)
2116 int flags_masked = k_flags & HVhek_MASK;
2117 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2118 if (HeHASH(entry) != hash) /* strings can't be equal */
2120 if (HeKLEN(entry) != len)
2122 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2124 if (HeKFLAGS(entry) != flags_masked)
2132 if (--HeVAL(entry) == Nullsv) {
2133 *oentry = HeNEXT(entry);
2135 xhv->xhv_fill--; /* HvFILL(hv)-- */
2136 Safefree(HeKEY_hek(entry));
2138 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2142 UNLOCK_STRTAB_MUTEX;
2143 if (!found && ckWARN_d(WARN_INTERNAL))
2144 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2145 "Attempt to free non-existent shared string '%s'%s",
2146 hek ? HEK_KEY(hek) : str,
2147 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2148 if (k_flags & HVhek_FREEKEY)
2152 /* get a (constant) string ptr from the global string table
2153 * string will get added if it is not already there.
2154 * len and hash must both be valid for str.
2157 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2159 bool is_utf8 = FALSE;
2161 const char *save = str;
2164 STRLEN tmplen = -len;
2166 /* See the note in hv_fetch(). --jhi */
2167 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2169 /* If we were able to downgrade here, then than means that we were passed
2170 in a key which only had chars 0-255, but was utf8 encoded. */
2173 /* If we found we were able to downgrade the string to bytes, then
2174 we should flag that it needs upgrading on keys or each. Also flag
2175 that we need share_hek_flags to free the string. */
2177 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2180 return share_hek_flags (str, len, hash, flags);
2184 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2186 register XPVHV* xhv;
2188 register HE **oentry;
2191 int flags_masked = flags & HVhek_MASK;
2193 /* what follows is the moral equivalent of:
2195 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2196 hv_store(PL_strtab, str, len, Nullsv, hash);
2198 xhv = (XPVHV*)SvANY(PL_strtab);
2199 /* assert(xhv_array != 0) */
2201 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2202 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2203 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2204 if (HeHASH(entry) != hash) /* strings can't be equal */
2206 if (HeKLEN(entry) != len)
2208 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2210 if (HeKFLAGS(entry) != flags_masked)
2217 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2218 HeVAL(entry) = Nullsv;
2219 HeNEXT(entry) = *oentry;
2221 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2222 if (i) { /* initial entry? */
2223 xhv->xhv_fill++; /* HvFILL(hv)++ */
2224 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
2229 ++HeVAL(entry); /* use value slot as REFCNT */
2230 UNLOCK_STRTAB_MUTEX;
2232 if (flags & HVhek_FREEKEY)
2235 return HeKEY_hek(entry);