3 * Copyright (c) 1991-2003, 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))) {
885 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
886 /* No longer an element */
887 sv_unmagic(sv, PERL_MAGIC_tiedelem);
890 return Nullsv; /* element cannot be deleted */
892 #ifdef ENV_IS_CASELESS
893 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
894 sv = sv_2mortal(newSVpvn(key,klen));
895 key = strupr(SvPVX(sv));
900 xhv = (XPVHV*)SvANY(hv);
901 if (!xhv->xhv_array /* !HvARRAY(hv) */)
905 STRLEN tmplen = klen;
906 /* See the note in hv_fetch(). --jhi */
907 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
910 k_flags = HVhek_UTF8;
912 k_flags |= HVhek_FREEKEY;
915 PERL_HASH(hash, key, klen);
917 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
918 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
921 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
922 if (HeHASH(entry) != hash) /* strings can't be equal */
924 if (HeKLEN(entry) != (I32)klen)
926 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
928 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
930 if (k_flags & HVhek_FREEKEY)
932 /* if placeholder is here, it's already been deleted.... */
933 if (HeVAL(entry) == &PL_sv_undef)
936 return Nullsv; /* if still SvREADONLY, leave it deleted. */
938 /* okay, really delete the placeholder... */
939 *oentry = HeNEXT(entry);
941 xhv->xhv_fill--; /* HvFILL(hv)-- */
942 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
945 hv_free_ent(hv, entry);
946 xhv->xhv_keys--; /* HvKEYS(hv)-- */
947 if (xhv->xhv_keys == 0)
949 xhv->xhv_placeholders--;
953 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
954 S_hv_notallowed(aTHX_ k_flags, key, klen,
955 "delete readonly key '%"SVf"' from"
959 if (flags & G_DISCARD)
962 sv = sv_2mortal(HeVAL(entry));
963 HeVAL(entry) = &PL_sv_undef;
967 * If a restricted hash, rather than really deleting the entry, put
968 * a placeholder there. This marks the key as being "approved", so
969 * we can still access via not-really-existing key without raising
972 if (SvREADONLY(hv)) {
973 HeVAL(entry) = &PL_sv_undef;
974 /* We'll be saving this slot, so the number of allocated keys
975 * doesn't go down, but the number placeholders goes up */
976 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
978 *oentry = HeNEXT(entry);
980 xhv->xhv_fill--; /* HvFILL(hv)-- */
981 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
984 hv_free_ent(hv, entry);
985 xhv->xhv_keys--; /* HvKEYS(hv)-- */
986 if (xhv->xhv_keys == 0)
991 if (SvREADONLY(hv)) {
992 S_hv_notallowed(aTHX_ k_flags, key, klen,
993 "access disallowed key '%"SVf"' from"
997 if (k_flags & HVhek_FREEKEY)
1003 =for apidoc hv_delete_ent
1005 Deletes a key/value pair in the hash. The value SV is removed from the
1006 hash and returned to the caller. The C<flags> value will normally be zero;
1007 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
1008 precomputed hash value, or 0 to ask for it to be computed.
1014 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1016 register XPVHV* xhv;
1021 register HE **oentry;
1029 if (SvRMAGICAL(hv)) {
1032 hv_magic_check (hv, &needs_copy, &needs_store);
1034 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
1036 if (SvMAGICAL(sv)) {
1040 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1041 /* No longer an element */
1042 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1045 return Nullsv; /* element cannot be deleted */
1047 #ifdef ENV_IS_CASELESS
1048 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1049 key = SvPV(keysv, klen);
1050 keysv = sv_2mortal(newSVpvn(key,klen));
1051 (void)strupr(SvPVX(keysv));
1057 xhv = (XPVHV*)SvANY(hv);
1058 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1061 keysave = key = SvPV(keysv, klen);
1062 is_utf8 = (SvUTF8(keysv) != 0);
1065 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1067 k_flags = HVhek_UTF8;
1069 k_flags |= HVhek_FREEKEY;
1073 PERL_HASH(hash, key, klen);
1075 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1076 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1079 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1080 if (HeHASH(entry) != hash) /* strings can't be equal */
1082 if (HeKLEN(entry) != (I32)klen)
1084 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1086 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1088 if (k_flags & HVhek_FREEKEY)
1091 /* if placeholder is here, it's already been deleted.... */
1092 if (HeVAL(entry) == &PL_sv_undef)
1095 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1097 /* okay, really delete the placeholder. */
1098 *oentry = HeNEXT(entry);
1100 xhv->xhv_fill--; /* HvFILL(hv)-- */
1101 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1104 hv_free_ent(hv, entry);
1105 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1106 if (xhv->xhv_keys == 0)
1107 HvHASKFLAGS_off(hv);
1108 xhv->xhv_placeholders--;
1111 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1112 S_hv_notallowed(aTHX_ k_flags, key, klen,
1113 "delete readonly key '%"SVf"' from"
1117 if (flags & G_DISCARD)
1120 sv = sv_2mortal(HeVAL(entry));
1121 HeVAL(entry) = &PL_sv_undef;
1125 * If a restricted hash, rather than really deleting the entry, put
1126 * a placeholder there. This marks the key as being "approved", so
1127 * we can still access via not-really-existing key without raising
1130 if (SvREADONLY(hv)) {
1131 HeVAL(entry) = &PL_sv_undef;
1132 /* We'll be saving this slot, so the number of allocated keys
1133 * doesn't go down, but the number placeholders goes up */
1134 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1136 *oentry = HeNEXT(entry);
1138 xhv->xhv_fill--; /* HvFILL(hv)-- */
1139 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1142 hv_free_ent(hv, entry);
1143 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1144 if (xhv->xhv_keys == 0)
1145 HvHASKFLAGS_off(hv);
1149 if (SvREADONLY(hv)) {
1150 S_hv_notallowed(aTHX_ k_flags, key, klen,
1151 "delete disallowed key '%"SVf"' from"
1155 if (k_flags & HVhek_FREEKEY)
1161 =for apidoc hv_exists
1163 Returns a boolean indicating whether the specified hash key exists. The
1164 C<klen> is the length of the key.
1170 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1172 register XPVHV* xhv;
1176 bool is_utf8 = FALSE;
1177 const char *keysave = key;
1188 if (SvRMAGICAL(hv)) {
1189 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1190 sv = sv_newmortal();
1191 mg_copy((SV*)hv, sv, key, klen);
1192 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1193 return (bool)SvTRUE(sv);
1195 #ifdef ENV_IS_CASELESS
1196 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1197 sv = sv_2mortal(newSVpvn(key,klen));
1198 key = strupr(SvPVX(sv));
1203 xhv = (XPVHV*)SvANY(hv);
1204 #ifndef DYNAMIC_ENV_FETCH
1205 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1210 STRLEN tmplen = klen;
1211 /* See the note in hv_fetch(). --jhi */
1212 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1215 k_flags = HVhek_UTF8;
1217 k_flags |= HVhek_FREEKEY;
1220 PERL_HASH(hash, key, klen);
1222 #ifdef DYNAMIC_ENV_FETCH
1223 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1226 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1227 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1228 for (; entry; entry = HeNEXT(entry)) {
1229 if (HeHASH(entry) != hash) /* strings can't be equal */
1231 if (HeKLEN(entry) != klen)
1233 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1235 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1237 if (k_flags & HVhek_FREEKEY)
1239 /* If we find the key, but the value is a placeholder, return false. */
1240 if (HeVAL(entry) == &PL_sv_undef)
1245 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1246 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1248 char *env = PerlEnv_ENVgetenv_len(key,&len);
1250 sv = newSVpvn(env,len);
1252 (void)hv_store(hv,key,klen,sv,hash);
1253 if (k_flags & HVhek_FREEKEY)
1259 if (k_flags & HVhek_FREEKEY)
1266 =for apidoc hv_exists_ent
1268 Returns a boolean indicating whether the specified hash key exists. C<hash>
1269 can be a valid precomputed hash value, or 0 to ask for it to be
1276 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1278 register XPVHV* xhv;
1290 if (SvRMAGICAL(hv)) {
1291 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1292 SV* svret = sv_newmortal();
1293 sv = sv_newmortal();
1294 keysv = sv_2mortal(newSVsv(keysv));
1295 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1296 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1297 return (bool)SvTRUE(svret);
1299 #ifdef ENV_IS_CASELESS
1300 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1301 key = SvPV(keysv, klen);
1302 keysv = sv_2mortal(newSVpvn(key,klen));
1303 (void)strupr(SvPVX(keysv));
1309 xhv = (XPVHV*)SvANY(hv);
1310 #ifndef DYNAMIC_ENV_FETCH
1311 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1315 keysave = key = SvPV(keysv, klen);
1316 is_utf8 = (SvUTF8(keysv) != 0);
1318 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1320 k_flags = HVhek_UTF8;
1322 k_flags |= HVhek_FREEKEY;
1325 PERL_HASH(hash, key, klen);
1327 #ifdef DYNAMIC_ENV_FETCH
1328 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1331 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1332 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1333 for (; entry; entry = HeNEXT(entry)) {
1334 if (HeHASH(entry) != hash) /* strings can't be equal */
1336 if (HeKLEN(entry) != (I32)klen)
1338 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1340 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1342 if (k_flags & HVhek_FREEKEY)
1344 /* If we find the key, but the value is a placeholder, return false. */
1345 if (HeVAL(entry) == &PL_sv_undef)
1349 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1350 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1352 char *env = PerlEnv_ENVgetenv_len(key,&len);
1354 sv = newSVpvn(env,len);
1356 (void)hv_store_ent(hv,keysv,sv,hash);
1357 if (k_flags & HVhek_FREEKEY)
1363 if (k_flags & HVhek_FREEKEY)
1369 S_hsplit(pTHX_ HV *hv)
1371 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1372 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1373 register I32 newsize = oldsize * 2;
1375 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1379 register HE **oentry;
1382 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1383 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1389 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1394 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1395 if (oldsize >= 64) {
1396 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1397 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1400 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1404 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1405 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1406 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1409 for (i=0; i<oldsize; i++,aep++) {
1410 if (!*aep) /* non-existent */
1413 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1414 if ((HeHASH(entry) & newsize) != (U32)i) {
1415 *oentry = HeNEXT(entry);
1416 HeNEXT(entry) = *bep;
1418 xhv->xhv_fill++; /* HvFILL(hv)++ */
1423 oentry = &HeNEXT(entry);
1425 if (!*aep) /* everything moved */
1426 xhv->xhv_fill--; /* HvFILL(hv)-- */
1431 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1433 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1434 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1435 register I32 newsize;
1441 register HE **oentry;
1443 newsize = (I32) newmax; /* possible truncation here */
1444 if (newsize != newmax || newmax <= oldsize)
1446 while ((newsize & (1 + ~newsize)) != newsize) {
1447 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1449 if (newsize < newmax)
1451 if (newsize < newmax)
1452 return; /* overflow detection */
1454 a = xhv->xhv_array; /* HvARRAY(hv) */
1457 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1458 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1464 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1469 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1470 if (oldsize >= 64) {
1471 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1472 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1475 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1478 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1481 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1483 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1484 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1485 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1489 for (i=0; i<oldsize; i++,aep++) {
1490 if (!*aep) /* non-existent */
1492 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1493 if ((j = (HeHASH(entry) & newsize)) != i) {
1495 *oentry = HeNEXT(entry);
1496 if (!(HeNEXT(entry) = aep[j]))
1497 xhv->xhv_fill++; /* HvFILL(hv)++ */
1502 oentry = &HeNEXT(entry);
1504 if (!*aep) /* everything moved */
1505 xhv->xhv_fill--; /* HvFILL(hv)-- */
1512 Creates a new HV. The reference count is set to 1.
1521 register XPVHV* xhv;
1523 hv = (HV*)NEWSV(502,0);
1524 sv_upgrade((SV *)hv, SVt_PVHV);
1525 xhv = (XPVHV*)SvANY(hv);
1528 #ifndef NODEFAULT_SHAREKEYS
1529 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1531 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1532 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1533 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1534 (void)hv_iterinit(hv); /* so each() will start off right */
1539 Perl_newHVhv(pTHX_ HV *ohv)
1542 STRLEN hv_max, hv_fill;
1544 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1546 hv_max = HvMAX(ohv);
1548 if (!SvMAGICAL((SV *)ohv)) {
1549 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1551 bool shared = !!HvSHAREKEYS(ohv);
1552 HE **ents, **oents = (HE **)HvARRAY(ohv);
1554 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1557 /* In each bucket... */
1558 for (i = 0; i <= hv_max; i++) {
1559 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1566 /* Copy the linked list of entries. */
1567 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1568 U32 hash = HeHASH(oent);
1569 char *key = HeKEY(oent);
1570 STRLEN len = HeKLEN(oent);
1571 int flags = HeKFLAGS(oent);
1574 HeVAL(ent) = newSVsv(HeVAL(oent));
1576 = shared ? share_hek_flags(key, len, hash, flags)
1577 : save_hek_flags(key, len, hash, flags);
1588 HvFILL(hv) = hv_fill;
1589 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1593 /* Iterate over ohv, copying keys and values one at a time. */
1595 I32 riter = HvRITER(ohv);
1596 HE *eiter = HvEITER(ohv);
1598 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1599 while (hv_max && hv_max + 1 >= hv_fill * 2)
1600 hv_max = hv_max / 2;
1604 while ((entry = hv_iternext_flags(ohv, 0))) {
1605 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1606 newSVsv(HeVAL(entry)), HeHASH(entry),
1609 HvRITER(ohv) = riter;
1610 HvEITER(ohv) = eiter;
1617 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1624 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1625 PL_sub_generation++; /* may be deletion of method from stash */
1627 if (HeKLEN(entry) == HEf_SVKEY) {
1628 SvREFCNT_dec(HeKEY_sv(entry));
1629 Safefree(HeKEY_hek(entry));
1631 else if (HvSHAREKEYS(hv))
1632 unshare_hek(HeKEY_hek(entry));
1634 Safefree(HeKEY_hek(entry));
1639 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1643 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1644 PL_sub_generation++; /* may be deletion of method from stash */
1645 sv_2mortal(HeVAL(entry)); /* free between statements */
1646 if (HeKLEN(entry) == HEf_SVKEY) {
1647 sv_2mortal(HeKEY_sv(entry));
1648 Safefree(HeKEY_hek(entry));
1650 else if (HvSHAREKEYS(hv))
1651 unshare_hek(HeKEY_hek(entry));
1653 Safefree(HeKEY_hek(entry));
1658 =for apidoc hv_clear
1660 Clears a hash, making it empty.
1666 Perl_hv_clear(pTHX_ HV *hv)
1668 register XPVHV* xhv;
1672 if(SvREADONLY(hv)) {
1673 Perl_croak(aTHX_ "Attempt to clear a restricted hash");
1676 xhv = (XPVHV*)SvANY(hv);
1678 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1679 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1680 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1681 if (xhv->xhv_array /* HvARRAY(hv) */)
1682 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1683 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1688 HvHASKFLAGS_off(hv);
1692 S_hfreeentries(pTHX_ HV *hv)
1694 register HE **array;
1696 register HE *oentry = Null(HE*);
1707 array = HvARRAY(hv);
1712 entry = HeNEXT(entry);
1713 hv_free_ent(hv, oentry);
1718 entry = array[riter];
1721 (void)hv_iterinit(hv);
1725 =for apidoc hv_undef
1733 Perl_hv_undef(pTHX_ HV *hv)
1735 register XPVHV* xhv;
1738 xhv = (XPVHV*)SvANY(hv);
1740 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1742 Safefree(HvNAME(hv));
1745 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1746 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1747 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1748 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1749 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1756 =for apidoc hv_iterinit
1758 Prepares a starting point to traverse a hash table. Returns the number of
1759 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1760 currently only meaningful for hashes without tie magic.
1762 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1763 hash buckets that happen to be in use. If you still need that esoteric
1764 value, you can get it through the macro C<HvFILL(tb)>.
1771 Perl_hv_iterinit(pTHX_ HV *hv)
1773 register XPVHV* xhv;
1777 Perl_croak(aTHX_ "Bad hash");
1778 xhv = (XPVHV*)SvANY(hv);
1779 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1780 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1782 hv_free_ent(hv, entry);
1784 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1785 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1786 /* used to be xhv->xhv_fill before 5.004_65 */
1787 return XHvTOTALKEYS(xhv);
1790 =for apidoc hv_iternext
1792 Returns entries from a hash iterator. See C<hv_iterinit>.
1794 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1795 iterator currently points to, without losing your place or invalidating your
1796 iterator. Note that in this case the current entry is deleted from the hash
1797 with your iterator holding the last reference to it. Your iterator is flagged
1798 to free the entry on the next call to C<hv_iternext>, so you must not discard
1799 your iterator immediately else the entry will leak - call C<hv_iternext> to
1800 trigger the resource deallocation.
1806 Perl_hv_iternext(pTHX_ HV *hv)
1808 return hv_iternext_flags(hv, 0);
1812 =for apidoc hv_iternext_flags
1814 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1815 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1816 set the placeholders keys (for restricted hashes) will be returned in addition
1817 to normal keys. By default placeholders are automatically skipped over.
1818 Currently a placeholder is implemented with a value that is literally
1819 <&Perl_sv_undef> (a regular C<undef> value is a normal read-write SV for which
1820 C<!SvOK> is false). Note that the implementation of placeholders and
1821 restricted hashes may change, and the implementation currently is
1822 insufficiently abstracted for any change to be tidy.
1828 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1830 register XPVHV* xhv;
1836 Perl_croak(aTHX_ "Bad hash");
1837 xhv = (XPVHV*)SvANY(hv);
1838 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1840 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1841 SV *key = sv_newmortal();
1843 sv_setsv(key, HeSVKEY_force(entry));
1844 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1850 /* one HE per MAGICAL hash */
1851 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1853 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1855 HeKEY_hek(entry) = hek;
1856 HeKLEN(entry) = HEf_SVKEY;
1858 magic_nextpack((SV*) hv,mg,key);
1860 /* force key to stay around until next time */
1861 HeSVKEY_set(entry, SvREFCNT_inc(key));
1862 return entry; /* beware, hent_val is not set */
1865 SvREFCNT_dec(HeVAL(entry));
1866 Safefree(HeKEY_hek(entry));
1868 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1871 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1872 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1876 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1877 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1878 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1880 /* At start of hash, entry is NULL. */
1883 entry = HeNEXT(entry);
1884 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1886 * Skip past any placeholders -- don't want to include them in
1889 while (entry && HeVAL(entry) == &PL_sv_undef) {
1890 entry = HeNEXT(entry);
1895 /* OK. Come to the end of the current list. Grab the next one. */
1897 xhv->xhv_riter++; /* HvRITER(hv)++ */
1898 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1899 /* There is no next one. End of the hash. */
1900 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1903 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1904 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1906 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1907 /* If we have an entry, but it's a placeholder, don't count it.
1909 while (entry && HeVAL(entry) == &PL_sv_undef)
1910 entry = HeNEXT(entry);
1912 /* Will loop again if this linked list starts NULL
1913 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1914 or if we run through it and find only placeholders. */
1917 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1919 hv_free_ent(hv, oldentry);
1922 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1927 =for apidoc hv_iterkey
1929 Returns the key from the current position of the hash iterator. See
1936 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1938 if (HeKLEN(entry) == HEf_SVKEY) {
1940 char *p = SvPV(HeKEY_sv(entry), len);
1945 *retlen = HeKLEN(entry);
1946 return HeKEY(entry);
1950 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1952 =for apidoc hv_iterkeysv
1954 Returns the key as an C<SV*> from the current position of the hash
1955 iterator. The return value will always be a mortal copy of the key. Also
1962 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1964 if (HeKLEN(entry) != HEf_SVKEY) {
1965 HEK *hek = HeKEY_hek(entry);
1966 int flags = HEK_FLAGS(hek);
1969 if (flags & HVhek_WASUTF8) {
1971 Andreas would like keys he put in as utf8 to come back as utf8
1973 STRLEN utf8_len = HEK_LEN(hek);
1974 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1976 sv = newSVpvn ((char*)as_utf8, utf8_len);
1978 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1980 sv = newSVpvn_share(HEK_KEY(hek),
1981 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1984 return sv_2mortal(sv);
1986 return sv_mortalcopy(HeKEY_sv(entry));
1990 =for apidoc hv_iterval
1992 Returns the value from the current position of the hash iterator. See
1999 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2001 if (SvRMAGICAL(hv)) {
2002 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2003 SV* sv = sv_newmortal();
2004 if (HeKLEN(entry) == HEf_SVKEY)
2005 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2006 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2010 return HeVAL(entry);
2014 =for apidoc hv_iternextsv
2016 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2023 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2026 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2028 *key = hv_iterkey(he, retlen);
2029 return hv_iterval(hv, he);
2033 =for apidoc hv_magic
2035 Adds magic to a hash. See C<sv_magic>.
2041 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2043 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2046 #if 0 /* use the macro from hv.h instead */
2049 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2051 return HEK_KEY(share_hek(sv, len, hash));
2056 /* possibly free a shared string if no one has access to it
2057 * len and hash must both be valid for str.
2060 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2062 unshare_hek_or_pvn (NULL, str, len, hash);
2067 Perl_unshare_hek(pTHX_ HEK *hek)
2069 unshare_hek_or_pvn(hek, NULL, 0, 0);
2072 /* possibly free a shared string if no one has access to it
2073 hek if non-NULL takes priority over the other 3, else str, len and hash
2074 are used. If so, len and hash must both be valid for str.
2077 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2079 register XPVHV* xhv;
2081 register HE **oentry;
2084 bool is_utf8 = FALSE;
2086 const char *save = str;
2089 hash = HEK_HASH(hek);
2090 } else if (len < 0) {
2091 STRLEN tmplen = -len;
2093 /* See the note in hv_fetch(). --jhi */
2094 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2097 k_flags = HVhek_UTF8;
2099 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2102 /* what follows is the moral equivalent of:
2103 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2104 if (--*Svp == Nullsv)
2105 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2107 xhv = (XPVHV*)SvANY(PL_strtab);
2108 /* assert(xhv_array != 0) */
2110 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2111 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2113 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2114 if (HeKEY_hek(entry) != hek)
2120 int flags_masked = k_flags & HVhek_MASK;
2121 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2122 if (HeHASH(entry) != hash) /* strings can't be equal */
2124 if (HeKLEN(entry) != len)
2126 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2128 if (HeKFLAGS(entry) != flags_masked)
2136 if (--HeVAL(entry) == Nullsv) {
2137 *oentry = HeNEXT(entry);
2139 xhv->xhv_fill--; /* HvFILL(hv)-- */
2140 Safefree(HeKEY_hek(entry));
2142 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2146 UNLOCK_STRTAB_MUTEX;
2147 if (!found && ckWARN_d(WARN_INTERNAL))
2148 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2149 "Attempt to free non-existent shared string '%s'%s",
2150 hek ? HEK_KEY(hek) : str,
2151 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2152 if (k_flags & HVhek_FREEKEY)
2156 /* get a (constant) string ptr from the global string table
2157 * string will get added if it is not already there.
2158 * len and hash must both be valid for str.
2161 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2163 bool is_utf8 = FALSE;
2165 const char *save = str;
2168 STRLEN tmplen = -len;
2170 /* See the note in hv_fetch(). --jhi */
2171 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2173 /* If we were able to downgrade here, then than means that we were passed
2174 in a key which only had chars 0-255, but was utf8 encoded. */
2177 /* If we found we were able to downgrade the string to bytes, then
2178 we should flag that it needs upgrading on keys or each. Also flag
2179 that we need share_hek_flags to free the string. */
2181 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2184 return share_hek_flags (str, len, hash, flags);
2188 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2190 register XPVHV* xhv;
2192 register HE **oentry;
2195 int flags_masked = flags & HVhek_MASK;
2197 /* what follows is the moral equivalent of:
2199 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2200 hv_store(PL_strtab, str, len, Nullsv, hash);
2202 xhv = (XPVHV*)SvANY(PL_strtab);
2203 /* assert(xhv_array != 0) */
2205 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2206 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2207 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2208 if (HeHASH(entry) != hash) /* strings can't be equal */
2210 if (HeKLEN(entry) != len)
2212 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2214 if (HeKFLAGS(entry) != flags_masked)
2221 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2222 HeVAL(entry) = Nullsv;
2223 HeNEXT(entry) = *oentry;
2225 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2226 if (i) { /* initial entry? */
2227 xhv->xhv_fill++; /* HvFILL(hv)++ */
2228 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
2233 ++HeVAL(entry); /* use value slot as REFCNT */
2234 UNLOCK_STRTAB_MUTEX;
2236 if (flags & HVhek_FREEKEY)
2239 return HeKEY_hek(entry);