3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "I sit beside the fire and think of all that I have seen." --Bilbo
16 =head1 Hash Manipulation Functions
31 PL_he_root = HeNEXT(he);
40 HeNEXT(p) = (HE*)PL_he_root;
51 New(54, ptr, 1008/sizeof(XPV), XPV);
52 ptr->xpv_pv = (char*)PL_he_arenaroot;
53 PL_he_arenaroot = ptr;
56 heend = &he[1008 / sizeof(HE) - 1];
59 HeNEXT(he) = (HE*)(he + 1);
67 #define new_HE() (HE*)safemalloc(sizeof(HE))
68 #define del_HE(p) safefree((char*)p)
72 #define new_HE() new_he()
73 #define del_HE(p) del_he(p)
78 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
83 New(54, k, HEK_BASESIZE + len + 2, char);
85 Copy(str, HEK_KEY(hek), len, char);
86 HEK_KEY(hek)[len] = 0;
89 HEK_FLAGS(hek) = (unsigned char)flags;
93 #if defined(USE_ITHREADS)
95 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
101 /* look for it in the table first */
102 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
106 /* create anew and remember what it is */
108 ptr_table_store(PL_ptr_table, e, ret);
110 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
111 if (HeKLEN(e) == HEf_SVKEY)
112 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
114 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
117 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
119 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
122 #endif /* USE_ITHREADS */
125 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
128 SV *sv = sv_newmortal(), *esv = sv_newmortal();
129 if (!(flags & HVhek_FREEKEY)) {
130 sv_setpvn(sv, key, klen);
133 /* Need to free saved eventually assign to mortal SV */
134 SV *sv = sv_newmortal();
135 sv_usepvn(sv, (char *) key, klen);
137 if (flags & HVhek_UTF8) {
140 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
141 Perl_croak(aTHX_ SvPVX(esv), sv);
144 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
150 Returns the SV which corresponds to the specified key in the hash. The
151 C<klen> is the length of the key. If C<lval> is set then the fetch will be
152 part of a store. Check that the return value is non-null before
153 dereferencing it to an C<SV*>.
155 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
156 information on how to use this function on tied hashes.
163 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
165 bool is_utf8 = FALSE;
166 const char *keysave = key;
175 STRLEN tmplen = klen;
176 /* Just casting the &klen to (STRLEN) won't work well
177 * if STRLEN and I32 are of different widths. --jhi */
178 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
180 /* If we were able to downgrade here, then than means that we were
181 passed in a key which only had chars 0-255, but was utf8 encoded. */
184 /* If we found we were able to downgrade the string to bytes, then
185 we should flag that it needs upgrading on keys or each. */
187 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
190 return hv_fetch_flags (hv, key, klen, lval, flags);
194 S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
204 if (SvRMAGICAL(hv)) {
205 /* All this clause seems to be utf8 unaware.
206 By moving the utf8 stuff out to hv_fetch_flags I need to ensure
207 key doesn't leak. I've not tried solving the utf8-ness.
210 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
212 mg_copy((SV*)hv, sv, key, klen);
213 if (flags & HVhek_FREEKEY)
216 return &PL_hv_fetch_sv;
218 #ifdef ENV_IS_CASELESS
219 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
221 for (i = 0; i < klen; ++i)
222 if (isLOWER(key[i])) {
223 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
224 SV **ret = hv_fetch(hv, nkey, klen, 0);
226 ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
228 } else if (flags & HVhek_FREEKEY)
236 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
237 avoid unnecessary pointer dereferencing. */
238 xhv = (XPVHV*)SvANY(hv);
239 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
241 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
242 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
245 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
246 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
249 if (flags & HVhek_FREEKEY)
255 PERL_HASH(hash, key, klen);
257 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
258 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
259 for (; entry; entry = HeNEXT(entry)) {
260 if (HeHASH(entry) != hash) /* strings can't be equal */
262 if (HeKLEN(entry) != (I32)klen)
264 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
266 /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
267 flags is 1 if utf8. need HeKFLAGS(entry) also 1.
268 xor is true if bits differ, in which case this isn't a match. */
269 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
271 if (lval && HeKFLAGS(entry) != flags) {
272 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
273 But if entry was set previously with HVhek_WASUTF8 and key now
274 doesn't (or vice versa) then we should change the key's flag,
275 as this is assignment. */
276 if (HvSHAREKEYS(hv)) {
277 /* Need to swap the key we have for a key with the flags we
278 need. As keys are shared we can't just write to the flag,
279 so we share the new one, unshare the old one. */
280 int flags_nofree = flags & ~HVhek_FREEKEY;
281 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
282 unshare_hek (HeKEY_hek(entry));
283 HeKEY_hek(entry) = new_hek;
286 HeKFLAGS(entry) = flags;
288 if (flags & HVhek_FREEKEY)
290 /* if we find a placeholder, we pretend we haven't found anything */
291 if (HeVAL(entry) == &PL_sv_undef)
293 return &HeVAL(entry);
296 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
297 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
299 char *env = PerlEnv_ENVgetenv_len(key,&len);
301 sv = newSVpvn(env,len);
303 if (flags & HVhek_FREEKEY)
305 return hv_store(hv,key,klen,sv,hash);
309 if (!entry && SvREADONLY(hv)) {
310 S_hv_notallowed(aTHX_ flags, key, klen,
311 "access disallowed key '%"SVf"' in"
314 if (lval) { /* gonna assign to this, so it better be there */
316 return hv_store_flags(hv,key,klen,sv,hash,flags);
318 if (flags & HVhek_FREEKEY)
323 /* returns an HE * structure with the all fields set */
324 /* note that hent_val will be a mortal sv for MAGICAL hashes */
326 =for apidoc hv_fetch_ent
328 Returns the hash entry which corresponds to the specified key in the hash.
329 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
330 if you want the function to compute it. IF C<lval> is set then the fetch
331 will be part of a store. Make sure the return value is non-null before
332 accessing it. The return value when C<tb> is a tied hash is a pointer to a
333 static location, so be sure to make a copy of the structure if you need to
336 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
337 information on how to use this function on tied hashes.
343 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
357 if (SvRMAGICAL(hv)) {
358 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
360 keysv = sv_2mortal(newSVsv(keysv));
361 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
362 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
364 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
365 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
367 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
368 HeVAL(&PL_hv_fetch_ent_mh) = sv;
369 return &PL_hv_fetch_ent_mh;
371 #ifdef ENV_IS_CASELESS
372 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
374 key = SvPV(keysv, klen);
375 for (i = 0; i < klen; ++i)
376 if (isLOWER(key[i])) {
377 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
378 (void)strupr(SvPVX(nkeysv));
379 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
381 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
388 xhv = (XPVHV*)SvANY(hv);
389 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
391 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
392 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
395 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
396 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
402 keysave = key = SvPV(keysv, klen);
403 is_utf8 = (SvUTF8(keysv)!=0);
406 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
410 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
414 if SvIsCOW_shared_hash(keysv) {
417 PERL_HASH(hash, key, klen);
421 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
422 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
423 for (; entry; entry = HeNEXT(entry)) {
424 if (HeHASH(entry) != hash) /* strings can't be equal */
426 if (HeKLEN(entry) != (I32)klen)
428 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
430 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
432 if (lval && HeKFLAGS(entry) != flags) {
433 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
434 But if entry was set previously with HVhek_WASUTF8 and key now
435 doesn't (or vice versa) then we should change the key's flag,
436 as this is assignment. */
437 if (HvSHAREKEYS(hv)) {
438 /* Need to swap the key we have for a key with the flags we
439 need. As keys are shared we can't just write to the flag,
440 so we share the new one, unshare the old one. */
441 int flags_nofree = flags & ~HVhek_FREEKEY;
442 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
443 unshare_hek (HeKEY_hek(entry));
444 HeKEY_hek(entry) = new_hek;
447 HeKFLAGS(entry) = flags;
451 /* if we find a placeholder, we pretend we haven't found anything */
452 if (HeVAL(entry) == &PL_sv_undef)
456 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
457 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
459 char *env = PerlEnv_ENVgetenv_len(key,&len);
461 sv = newSVpvn(env,len);
463 return hv_store_ent(hv,keysv,sv,hash);
467 if (!entry && SvREADONLY(hv)) {
468 S_hv_notallowed(aTHX_ flags, key, klen,
469 "access disallowed key '%"SVf"' in"
472 if (flags & HVhek_FREEKEY)
474 if (lval) { /* gonna assign to this, so it better be there */
476 return hv_store_ent(hv,keysv,sv,hash);
482 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
484 MAGIC *mg = SvMAGIC(hv);
488 if (isUPPER(mg->mg_type)) {
490 switch (mg->mg_type) {
491 case PERL_MAGIC_tied:
493 *needs_store = FALSE;
496 mg = mg->mg_moremagic;
503 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
504 the length of the key. The C<hash> parameter is the precomputed hash
505 value; if it is zero then Perl will compute it. The return value will be
506 NULL if the operation failed or if the value did not need to be actually
507 stored within the hash (as in the case of tied hashes). Otherwise it can
508 be dereferenced to get the original C<SV*>. Note that the caller is
509 responsible for suitably incrementing the reference count of C<val> before
510 the call, and decrementing it if the function returned NULL. Effectively
511 a successful hv_store takes ownership of one reference to C<val>. This is
512 usually what you want; a newly created SV has a reference count of one, so
513 if all your code does is create SVs then store them in a hash, hv_store
514 will own the only reference to the new SV, and your code doesn't need to do
515 anything further to tidy up. hv_store is not implemented as a call to
516 hv_store_ent, and does not create a temporary SV for the key, so if your
517 key data is not already in SV form then use hv_store in preference to
520 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
521 information on how to use this function on tied hashes.
527 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
529 bool is_utf8 = FALSE;
530 const char *keysave = key;
539 STRLEN tmplen = klen;
540 /* Just casting the &klen to (STRLEN) won't work well
541 * if STRLEN and I32 are of different widths. --jhi */
542 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
544 /* If we were able to downgrade here, then than means that we were
545 passed in a key which only had chars 0-255, but was utf8 encoded. */
548 /* If we found we were able to downgrade the string to bytes, then
549 we should flag that it needs upgrading on keys or each. */
551 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
554 return hv_store_flags (hv, key, klen, val, hash, flags);
558 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
559 register U32 hash, int flags)
564 register HE **oentry;
569 xhv = (XPVHV*)SvANY(hv);
573 hv_magic_check (hv, &needs_copy, &needs_store);
575 mg_copy((SV*)hv, val, key, klen);
576 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
577 if (flags & HVhek_FREEKEY)
581 #ifdef ENV_IS_CASELESS
582 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
583 key = savepvn(key,klen);
584 key = (const char*)strupr((char*)key);
592 HvHASKFLAGS_on((SV*)hv);
595 PERL_HASH(hash, key, klen);
597 if (!xhv->xhv_array /* !HvARRAY(hv) */)
598 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
599 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
602 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
603 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
606 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
607 if (HeHASH(entry) != hash) /* strings can't be equal */
609 if (HeKLEN(entry) != (I32)klen)
611 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
613 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
615 if (HeVAL(entry) == &PL_sv_undef)
616 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
618 SvREFCNT_dec(HeVAL(entry));
619 if (flags & HVhek_PLACEHOLD) {
620 /* We have been requested to insert a placeholder. Currently
621 only Storable is allowed to do this. */
622 xhv->xhv_placeholders++;
623 HeVAL(entry) = &PL_sv_undef;
627 if (HeKFLAGS(entry) != flags) {
628 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
629 But if entry was set previously with HVhek_WASUTF8 and key now
630 doesn't (or vice versa) then we should change the key's flag,
631 as this is assignment. */
632 if (HvSHAREKEYS(hv)) {
633 /* Need to swap the key we have for a key with the flags we
634 need. As keys are shared we can't just write to the flag,
635 so we share the new one, unshare the old one. */
636 int flags_nofree = flags & ~HVhek_FREEKEY;
637 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
638 unshare_hek (HeKEY_hek(entry));
639 HeKEY_hek(entry) = new_hek;
642 HeKFLAGS(entry) = flags;
644 if (flags & HVhek_FREEKEY)
646 return &HeVAL(entry);
649 if (SvREADONLY(hv)) {
650 S_hv_notallowed(aTHX_ flags, key, klen,
651 "access disallowed key '%"SVf"' to"
656 /* share_hek_flags will do the free for us. This might be considered
659 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
660 else /* gotta do the real thing */
661 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
662 if (flags & HVhek_PLACEHOLD) {
663 /* We have been requested to insert a placeholder. Currently
664 only Storable is allowed to do this. */
665 xhv->xhv_placeholders++;
666 HeVAL(entry) = &PL_sv_undef;
669 HeNEXT(entry) = *oentry;
672 xhv->xhv_keys++; /* HvKEYS(hv)++ */
673 if (i) { /* initial entry? */
674 xhv->xhv_fill++; /* HvFILL(hv)++ */
675 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
679 return &HeVAL(entry);
683 =for apidoc hv_store_ent
685 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
686 parameter is the precomputed hash value; if it is zero then Perl will
687 compute it. The return value is the new hash entry so created. It will be
688 NULL if the operation failed or if the value did not need to be actually
689 stored within the hash (as in the case of tied hashes). Otherwise the
690 contents of the return value can be accessed using the C<He?> macros
691 described here. Note that the caller is responsible for suitably
692 incrementing the reference count of C<val> before the call, and
693 decrementing it if the function returned NULL. Effectively a successful
694 hv_store_ent takes ownership of one reference to C<val>. This is
695 usually what you want; a newly created SV has a reference count of one, so
696 if all your code does is create SVs then store them in a hash, hv_store
697 will own the only reference to the new SV, and your code doesn't need to do
698 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
699 unlike C<val> it does not take ownership of it, so maintaining the correct
700 reference count on C<key> is entirely the caller's responsibility. hv_store
701 is not implemented as a call to hv_store_ent, and does not create a temporary
702 SV for the key, so if your key data is not already in SV form then use
703 hv_store in preference to hv_store_ent.
705 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
706 information on how to use this function on tied hashes.
712 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
727 xhv = (XPVHV*)SvANY(hv);
731 hv_magic_check (hv, &needs_copy, &needs_store);
733 bool save_taint = PL_tainted;
735 PL_tainted = SvTAINTED(keysv);
736 keysv = sv_2mortal(newSVsv(keysv));
737 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
738 TAINT_IF(save_taint);
739 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
741 #ifdef ENV_IS_CASELESS
742 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
743 key = SvPV(keysv, klen);
744 keysv = sv_2mortal(newSVpvn(key,klen));
745 (void)strupr(SvPVX(keysv));
752 keysave = key = SvPV(keysv, klen);
753 is_utf8 = (SvUTF8(keysv) != 0);
756 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
760 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
761 HvHASKFLAGS_on((SV*)hv);
765 if SvIsCOW_shared_hash(keysv) {
768 PERL_HASH(hash, key, klen);
772 if (!xhv->xhv_array /* !HvARRAY(hv) */)
773 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
774 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
777 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
778 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
781 for (; entry; i=0, entry = HeNEXT(entry)) {
782 if (HeHASH(entry) != hash) /* strings can't be equal */
784 if (HeKLEN(entry) != (I32)klen)
786 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
788 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
790 if (HeVAL(entry) == &PL_sv_undef)
791 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
793 SvREFCNT_dec(HeVAL(entry));
795 if (HeKFLAGS(entry) != flags) {
796 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
797 But if entry was set previously with HVhek_WASUTF8 and key now
798 doesn't (or vice versa) then we should change the key's flag,
799 as this is assignment. */
800 if (HvSHAREKEYS(hv)) {
801 /* Need to swap the key we have for a key with the flags we
802 need. As keys are shared we can't just write to the flag,
803 so we share the new one, unshare the old one. */
804 int flags_nofree = flags & ~HVhek_FREEKEY;
805 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
806 unshare_hek (HeKEY_hek(entry));
807 HeKEY_hek(entry) = new_hek;
810 HeKFLAGS(entry) = flags;
812 if (flags & HVhek_FREEKEY)
817 if (SvREADONLY(hv)) {
818 S_hv_notallowed(aTHX_ flags, key, klen,
819 "access disallowed key '%"SVf"' to"
824 /* share_hek_flags will do the free for us. This might be considered
827 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
828 else /* gotta do the real thing */
829 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
831 HeNEXT(entry) = *oentry;
834 xhv->xhv_keys++; /* HvKEYS(hv)++ */
835 if (i) { /* initial entry? */
836 xhv->xhv_fill++; /* HvFILL(hv)++ */
837 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
845 =for apidoc hv_delete
847 Deletes a key/value pair in the hash. The value SV is removed from the
848 hash and returned to the caller. The C<klen> is the length of the key.
849 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
856 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
862 register HE **oentry;
865 bool is_utf8 = FALSE;
867 const char *keysave = key;
875 if (SvRMAGICAL(hv)) {
878 hv_magic_check (hv, &needs_copy, &needs_store);
880 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
886 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
887 /* No longer an element */
888 sv_unmagic(sv, PERL_MAGIC_tiedelem);
891 return Nullsv; /* element cannot be deleted */
893 #ifdef ENV_IS_CASELESS
894 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
895 sv = sv_2mortal(newSVpvn(key,klen));
896 key = strupr(SvPVX(sv));
901 xhv = (XPVHV*)SvANY(hv);
902 if (!xhv->xhv_array /* !HvARRAY(hv) */)
906 STRLEN tmplen = klen;
907 /* See the note in hv_fetch(). --jhi */
908 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
911 k_flags = HVhek_UTF8;
913 k_flags |= HVhek_FREEKEY;
916 PERL_HASH(hash, key, klen);
918 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
919 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
922 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
923 if (HeHASH(entry) != hash) /* strings can't be equal */
925 if (HeKLEN(entry) != (I32)klen)
927 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
929 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
931 if (k_flags & HVhek_FREEKEY)
933 /* if placeholder is here, it's already been deleted.... */
934 if (HeVAL(entry) == &PL_sv_undef)
937 return Nullsv; /* if still SvREADONLY, leave it deleted. */
939 /* okay, really delete the placeholder... */
940 *oentry = HeNEXT(entry);
942 xhv->xhv_fill--; /* HvFILL(hv)-- */
943 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
946 hv_free_ent(hv, entry);
947 xhv->xhv_keys--; /* HvKEYS(hv)-- */
948 if (xhv->xhv_keys == 0)
950 xhv->xhv_placeholders--;
954 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
955 S_hv_notallowed(aTHX_ k_flags, key, klen,
956 "delete readonly key '%"SVf"' from"
960 if (flags & G_DISCARD)
963 sv = sv_2mortal(HeVAL(entry));
964 HeVAL(entry) = &PL_sv_undef;
968 * If a restricted hash, rather than really deleting the entry, put
969 * a placeholder there. This marks the key as being "approved", so
970 * we can still access via not-really-existing key without raising
973 if (SvREADONLY(hv)) {
974 HeVAL(entry) = &PL_sv_undef;
975 /* We'll be saving this slot, so the number of allocated keys
976 * doesn't go down, but the number placeholders goes up */
977 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
979 *oentry = HeNEXT(entry);
981 xhv->xhv_fill--; /* HvFILL(hv)-- */
982 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
985 hv_free_ent(hv, entry);
986 xhv->xhv_keys--; /* HvKEYS(hv)-- */
987 if (xhv->xhv_keys == 0)
992 if (SvREADONLY(hv)) {
993 S_hv_notallowed(aTHX_ k_flags, key, klen,
994 "access disallowed key '%"SVf"' from"
998 if (k_flags & HVhek_FREEKEY)
1004 =for apidoc hv_delete_ent
1006 Deletes a key/value pair in the hash. The value SV is removed from the
1007 hash and returned to the caller. The C<flags> value will normally be zero;
1008 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
1009 precomputed hash value, or 0 to ask for it to be computed.
1015 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1017 register XPVHV* xhv;
1022 register HE **oentry;
1030 if (SvRMAGICAL(hv)) {
1033 hv_magic_check (hv, &needs_copy, &needs_store);
1035 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
1037 if (SvMAGICAL(sv)) {
1041 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1042 /* No longer an element */
1043 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1046 return Nullsv; /* element cannot be deleted */
1048 #ifdef ENV_IS_CASELESS
1049 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1050 key = SvPV(keysv, klen);
1051 keysv = sv_2mortal(newSVpvn(key,klen));
1052 (void)strupr(SvPVX(keysv));
1058 xhv = (XPVHV*)SvANY(hv);
1059 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1062 keysave = key = SvPV(keysv, klen);
1063 is_utf8 = (SvUTF8(keysv) != 0);
1066 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1068 k_flags = HVhek_UTF8;
1070 k_flags |= HVhek_FREEKEY;
1074 PERL_HASH(hash, key, klen);
1076 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1077 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1080 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1081 if (HeHASH(entry) != hash) /* strings can't be equal */
1083 if (HeKLEN(entry) != (I32)klen)
1085 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1087 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1089 if (k_flags & HVhek_FREEKEY)
1092 /* if placeholder is here, it's already been deleted.... */
1093 if (HeVAL(entry) == &PL_sv_undef)
1096 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1098 /* okay, really delete the placeholder. */
1099 *oentry = HeNEXT(entry);
1101 xhv->xhv_fill--; /* HvFILL(hv)-- */
1102 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1105 hv_free_ent(hv, entry);
1106 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1107 if (xhv->xhv_keys == 0)
1108 HvHASKFLAGS_off(hv);
1109 xhv->xhv_placeholders--;
1112 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1113 S_hv_notallowed(aTHX_ k_flags, key, klen,
1114 "delete readonly key '%"SVf"' from"
1118 if (flags & G_DISCARD)
1121 sv = sv_2mortal(HeVAL(entry));
1122 HeVAL(entry) = &PL_sv_undef;
1126 * If a restricted hash, rather than really deleting the entry, put
1127 * a placeholder there. This marks the key as being "approved", so
1128 * we can still access via not-really-existing key without raising
1131 if (SvREADONLY(hv)) {
1132 HeVAL(entry) = &PL_sv_undef;
1133 /* We'll be saving this slot, so the number of allocated keys
1134 * doesn't go down, but the number placeholders goes up */
1135 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1137 *oentry = HeNEXT(entry);
1139 xhv->xhv_fill--; /* HvFILL(hv)-- */
1140 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1143 hv_free_ent(hv, entry);
1144 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1145 if (xhv->xhv_keys == 0)
1146 HvHASKFLAGS_off(hv);
1150 if (SvREADONLY(hv)) {
1151 S_hv_notallowed(aTHX_ k_flags, key, klen,
1152 "delete disallowed key '%"SVf"' from"
1156 if (k_flags & HVhek_FREEKEY)
1162 =for apidoc hv_exists
1164 Returns a boolean indicating whether the specified hash key exists. The
1165 C<klen> is the length of the key.
1171 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1173 register XPVHV* xhv;
1177 bool is_utf8 = FALSE;
1178 const char *keysave = key;
1189 if (SvRMAGICAL(hv)) {
1190 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1191 sv = sv_newmortal();
1192 mg_copy((SV*)hv, sv, key, klen);
1193 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1194 return (bool)SvTRUE(sv);
1196 #ifdef ENV_IS_CASELESS
1197 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1198 sv = sv_2mortal(newSVpvn(key,klen));
1199 key = strupr(SvPVX(sv));
1204 xhv = (XPVHV*)SvANY(hv);
1205 #ifndef DYNAMIC_ENV_FETCH
1206 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1211 STRLEN tmplen = klen;
1212 /* See the note in hv_fetch(). --jhi */
1213 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1216 k_flags = HVhek_UTF8;
1218 k_flags |= HVhek_FREEKEY;
1221 PERL_HASH(hash, key, klen);
1223 #ifdef DYNAMIC_ENV_FETCH
1224 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1227 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1228 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1229 for (; entry; entry = HeNEXT(entry)) {
1230 if (HeHASH(entry) != hash) /* strings can't be equal */
1232 if (HeKLEN(entry) != klen)
1234 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1236 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1238 if (k_flags & HVhek_FREEKEY)
1240 /* If we find the key, but the value is a placeholder, return false. */
1241 if (HeVAL(entry) == &PL_sv_undef)
1246 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1247 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1249 char *env = PerlEnv_ENVgetenv_len(key,&len);
1251 sv = newSVpvn(env,len);
1253 (void)hv_store(hv,key,klen,sv,hash);
1254 if (k_flags & HVhek_FREEKEY)
1260 if (k_flags & HVhek_FREEKEY)
1267 =for apidoc hv_exists_ent
1269 Returns a boolean indicating whether the specified hash key exists. C<hash>
1270 can be a valid precomputed hash value, or 0 to ask for it to be
1277 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1279 register XPVHV* xhv;
1291 if (SvRMAGICAL(hv)) {
1292 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1293 SV* svret = sv_newmortal();
1294 sv = sv_newmortal();
1295 keysv = sv_2mortal(newSVsv(keysv));
1296 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1297 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1298 return (bool)SvTRUE(svret);
1300 #ifdef ENV_IS_CASELESS
1301 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1302 key = SvPV(keysv, klen);
1303 keysv = sv_2mortal(newSVpvn(key,klen));
1304 (void)strupr(SvPVX(keysv));
1310 xhv = (XPVHV*)SvANY(hv);
1311 #ifndef DYNAMIC_ENV_FETCH
1312 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1316 keysave = key = SvPV(keysv, klen);
1317 is_utf8 = (SvUTF8(keysv) != 0);
1319 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1321 k_flags = HVhek_UTF8;
1323 k_flags |= HVhek_FREEKEY;
1326 PERL_HASH(hash, key, klen);
1328 #ifdef DYNAMIC_ENV_FETCH
1329 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1332 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1333 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1334 for (; entry; entry = HeNEXT(entry)) {
1335 if (HeHASH(entry) != hash) /* strings can't be equal */
1337 if (HeKLEN(entry) != (I32)klen)
1339 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1341 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1343 if (k_flags & HVhek_FREEKEY)
1345 /* If we find the key, but the value is a placeholder, return false. */
1346 if (HeVAL(entry) == &PL_sv_undef)
1350 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1351 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1353 char *env = PerlEnv_ENVgetenv_len(key,&len);
1355 sv = newSVpvn(env,len);
1357 (void)hv_store_ent(hv,keysv,sv,hash);
1358 if (k_flags & HVhek_FREEKEY)
1364 if (k_flags & HVhek_FREEKEY)
1370 S_hsplit(pTHX_ HV *hv)
1372 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1373 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1374 register I32 newsize = oldsize * 2;
1376 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1380 register HE **oentry;
1383 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1384 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1390 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1395 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1396 if (oldsize >= 64) {
1397 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1398 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1401 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1405 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1406 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1407 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1410 for (i=0; i<oldsize; i++,aep++) {
1411 if (!*aep) /* non-existent */
1414 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1415 if ((HeHASH(entry) & newsize) != (U32)i) {
1416 *oentry = HeNEXT(entry);
1417 HeNEXT(entry) = *bep;
1419 xhv->xhv_fill++; /* HvFILL(hv)++ */
1424 oentry = &HeNEXT(entry);
1426 if (!*aep) /* everything moved */
1427 xhv->xhv_fill--; /* HvFILL(hv)-- */
1432 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1434 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1435 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1436 register I32 newsize;
1442 register HE **oentry;
1444 newsize = (I32) newmax; /* possible truncation here */
1445 if (newsize != newmax || newmax <= oldsize)
1447 while ((newsize & (1 + ~newsize)) != newsize) {
1448 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1450 if (newsize < newmax)
1452 if (newsize < newmax)
1453 return; /* overflow detection */
1455 a = xhv->xhv_array; /* HvARRAY(hv) */
1458 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1459 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1465 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1470 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1471 if (oldsize >= 64) {
1472 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1473 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1476 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1479 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1482 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1484 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1485 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1486 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1490 for (i=0; i<oldsize; i++,aep++) {
1491 if (!*aep) /* non-existent */
1493 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1494 if ((j = (HeHASH(entry) & newsize)) != i) {
1496 *oentry = HeNEXT(entry);
1497 if (!(HeNEXT(entry) = aep[j]))
1498 xhv->xhv_fill++; /* HvFILL(hv)++ */
1503 oentry = &HeNEXT(entry);
1505 if (!*aep) /* everything moved */
1506 xhv->xhv_fill--; /* HvFILL(hv)-- */
1513 Creates a new HV. The reference count is set to 1.
1522 register XPVHV* xhv;
1524 hv = (HV*)NEWSV(502,0);
1525 sv_upgrade((SV *)hv, SVt_PVHV);
1526 xhv = (XPVHV*)SvANY(hv);
1529 #ifndef NODEFAULT_SHAREKEYS
1530 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1532 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1533 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1534 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1535 (void)hv_iterinit(hv); /* so each() will start off right */
1540 Perl_newHVhv(pTHX_ HV *ohv)
1543 STRLEN hv_max, hv_fill;
1545 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1547 hv_max = HvMAX(ohv);
1549 if (!SvMAGICAL((SV *)ohv)) {
1550 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1552 bool shared = !!HvSHAREKEYS(ohv);
1553 HE **ents, **oents = (HE **)HvARRAY(ohv);
1555 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1558 /* In each bucket... */
1559 for (i = 0; i <= hv_max; i++) {
1560 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1567 /* Copy the linked list of entries. */
1568 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1569 U32 hash = HeHASH(oent);
1570 char *key = HeKEY(oent);
1571 STRLEN len = HeKLEN(oent);
1572 int flags = HeKFLAGS(oent);
1575 HeVAL(ent) = newSVsv(HeVAL(oent));
1577 = shared ? share_hek_flags(key, len, hash, flags)
1578 : save_hek_flags(key, len, hash, flags);
1589 HvFILL(hv) = hv_fill;
1590 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1594 /* Iterate over ohv, copying keys and values one at a time. */
1596 I32 riter = HvRITER(ohv);
1597 HE *eiter = HvEITER(ohv);
1599 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1600 while (hv_max && hv_max + 1 >= hv_fill * 2)
1601 hv_max = hv_max / 2;
1605 while ((entry = hv_iternext_flags(ohv, 0))) {
1606 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1607 newSVsv(HeVAL(entry)), HeHASH(entry),
1610 HvRITER(ohv) = riter;
1611 HvEITER(ohv) = eiter;
1618 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1625 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1626 PL_sub_generation++; /* may be deletion of method from stash */
1628 if (HeKLEN(entry) == HEf_SVKEY) {
1629 SvREFCNT_dec(HeKEY_sv(entry));
1630 Safefree(HeKEY_hek(entry));
1632 else if (HvSHAREKEYS(hv))
1633 unshare_hek(HeKEY_hek(entry));
1635 Safefree(HeKEY_hek(entry));
1640 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1644 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1645 PL_sub_generation++; /* may be deletion of method from stash */
1646 sv_2mortal(HeVAL(entry)); /* free between statements */
1647 if (HeKLEN(entry) == HEf_SVKEY) {
1648 sv_2mortal(HeKEY_sv(entry));
1649 Safefree(HeKEY_hek(entry));
1651 else if (HvSHAREKEYS(hv))
1652 unshare_hek(HeKEY_hek(entry));
1654 Safefree(HeKEY_hek(entry));
1659 =for apidoc hv_clear
1661 Clears a hash, making it empty.
1667 Perl_hv_clear(pTHX_ HV *hv)
1669 register XPVHV* xhv;
1673 if(SvREADONLY(hv)) {
1674 Perl_croak(aTHX_ "Attempt to clear a restricted hash");
1677 xhv = (XPVHV*)SvANY(hv);
1679 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1680 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1681 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1682 if (xhv->xhv_array /* HvARRAY(hv) */)
1683 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1684 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1689 HvHASKFLAGS_off(hv);
1693 S_hfreeentries(pTHX_ HV *hv)
1695 register HE **array;
1697 register HE *oentry = Null(HE*);
1708 array = HvARRAY(hv);
1713 entry = HeNEXT(entry);
1714 hv_free_ent(hv, oentry);
1719 entry = array[riter];
1722 (void)hv_iterinit(hv);
1726 =for apidoc hv_undef
1734 Perl_hv_undef(pTHX_ HV *hv)
1736 register XPVHV* xhv;
1739 xhv = (XPVHV*)SvANY(hv);
1741 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1744 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1745 Safefree(HvNAME(hv));
1748 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1749 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1750 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1751 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1752 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1759 =for apidoc hv_iterinit
1761 Prepares a starting point to traverse a hash table. Returns the number of
1762 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1763 currently only meaningful for hashes without tie magic.
1765 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1766 hash buckets that happen to be in use. If you still need that esoteric
1767 value, you can get it through the macro C<HvFILL(tb)>.
1774 Perl_hv_iterinit(pTHX_ HV *hv)
1776 register XPVHV* xhv;
1780 Perl_croak(aTHX_ "Bad hash");
1781 xhv = (XPVHV*)SvANY(hv);
1782 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1783 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1785 hv_free_ent(hv, entry);
1787 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1788 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1789 /* used to be xhv->xhv_fill before 5.004_65 */
1790 return XHvTOTALKEYS(xhv);
1793 =for apidoc hv_iternext
1795 Returns entries from a hash iterator. See C<hv_iterinit>.
1797 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1798 iterator currently points to, without losing your place or invalidating your
1799 iterator. Note that in this case the current entry is deleted from the hash
1800 with your iterator holding the last reference to it. Your iterator is flagged
1801 to free the entry on the next call to C<hv_iternext>, so you must not discard
1802 your iterator immediately else the entry will leak - call C<hv_iternext> to
1803 trigger the resource deallocation.
1809 Perl_hv_iternext(pTHX_ HV *hv)
1811 return hv_iternext_flags(hv, 0);
1815 =for apidoc hv_iternext_flags
1817 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1818 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1819 set the placeholders keys (for restricted hashes) will be returned in addition
1820 to normal keys. By default placeholders are automatically skipped over.
1821 Currently a placeholder is implemented with a value that is literally
1822 <&Perl_sv_undef> (a regular C<undef> value is a normal read-write SV for which
1823 C<!SvOK> is false). Note that the implementation of placeholders and
1824 restricted hashes may change, and the implementation currently is
1825 insufficiently abstracted for any change to be tidy.
1831 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1833 register XPVHV* xhv;
1839 Perl_croak(aTHX_ "Bad hash");
1840 xhv = (XPVHV*)SvANY(hv);
1841 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1843 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1844 SV *key = sv_newmortal();
1846 sv_setsv(key, HeSVKEY_force(entry));
1847 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1853 /* one HE per MAGICAL hash */
1854 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1856 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1858 HeKEY_hek(entry) = hek;
1859 HeKLEN(entry) = HEf_SVKEY;
1861 magic_nextpack((SV*) hv,mg,key);
1863 /* force key to stay around until next time */
1864 HeSVKEY_set(entry, SvREFCNT_inc(key));
1865 return entry; /* beware, hent_val is not set */
1868 SvREFCNT_dec(HeVAL(entry));
1869 Safefree(HeKEY_hek(entry));
1871 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1874 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1875 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1879 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1880 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1881 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1883 /* At start of hash, entry is NULL. */
1886 entry = HeNEXT(entry);
1887 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1889 * Skip past any placeholders -- don't want to include them in
1892 while (entry && HeVAL(entry) == &PL_sv_undef) {
1893 entry = HeNEXT(entry);
1898 /* OK. Come to the end of the current list. Grab the next one. */
1900 xhv->xhv_riter++; /* HvRITER(hv)++ */
1901 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1902 /* There is no next one. End of the hash. */
1903 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1906 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1907 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1909 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1910 /* If we have an entry, but it's a placeholder, don't count it.
1912 while (entry && HeVAL(entry) == &PL_sv_undef)
1913 entry = HeNEXT(entry);
1915 /* Will loop again if this linked list starts NULL
1916 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1917 or if we run through it and find only placeholders. */
1920 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1922 hv_free_ent(hv, oldentry);
1925 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1930 =for apidoc hv_iterkey
1932 Returns the key from the current position of the hash iterator. See
1939 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1941 if (HeKLEN(entry) == HEf_SVKEY) {
1943 char *p = SvPV(HeKEY_sv(entry), len);
1948 *retlen = HeKLEN(entry);
1949 return HeKEY(entry);
1953 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1955 =for apidoc hv_iterkeysv
1957 Returns the key as an C<SV*> from the current position of the hash
1958 iterator. The return value will always be a mortal copy of the key. Also
1965 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1967 if (HeKLEN(entry) != HEf_SVKEY) {
1968 HEK *hek = HeKEY_hek(entry);
1969 int flags = HEK_FLAGS(hek);
1972 if (flags & HVhek_WASUTF8) {
1974 Andreas would like keys he put in as utf8 to come back as utf8
1976 STRLEN utf8_len = HEK_LEN(hek);
1977 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1979 sv = newSVpvn ((char*)as_utf8, utf8_len);
1981 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1983 sv = newSVpvn_share(HEK_KEY(hek),
1984 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1987 return sv_2mortal(sv);
1989 return sv_mortalcopy(HeKEY_sv(entry));
1993 =for apidoc hv_iterval
1995 Returns the value from the current position of the hash iterator. See
2002 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2004 if (SvRMAGICAL(hv)) {
2005 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2006 SV* sv = sv_newmortal();
2007 if (HeKLEN(entry) == HEf_SVKEY)
2008 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2009 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2013 return HeVAL(entry);
2017 =for apidoc hv_iternextsv
2019 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2026 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2029 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2031 *key = hv_iterkey(he, retlen);
2032 return hv_iterval(hv, he);
2036 =for apidoc hv_magic
2038 Adds magic to a hash. See C<sv_magic>.
2044 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2046 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2049 #if 0 /* use the macro from hv.h instead */
2052 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2054 return HEK_KEY(share_hek(sv, len, hash));
2059 /* possibly free a shared string if no one has access to it
2060 * len and hash must both be valid for str.
2063 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2065 unshare_hek_or_pvn (NULL, str, len, hash);
2070 Perl_unshare_hek(pTHX_ HEK *hek)
2072 unshare_hek_or_pvn(hek, NULL, 0, 0);
2075 /* possibly free a shared string if no one has access to it
2076 hek if non-NULL takes priority over the other 3, else str, len and hash
2077 are used. If so, len and hash must both be valid for str.
2080 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2082 register XPVHV* xhv;
2084 register HE **oentry;
2087 bool is_utf8 = FALSE;
2089 const char *save = str;
2092 hash = HEK_HASH(hek);
2093 } else if (len < 0) {
2094 STRLEN tmplen = -len;
2096 /* See the note in hv_fetch(). --jhi */
2097 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2100 k_flags = HVhek_UTF8;
2102 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2105 /* what follows is the moral equivalent of:
2106 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2107 if (--*Svp == Nullsv)
2108 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2110 xhv = (XPVHV*)SvANY(PL_strtab);
2111 /* assert(xhv_array != 0) */
2113 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2114 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2116 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2117 if (HeKEY_hek(entry) != hek)
2123 int flags_masked = k_flags & HVhek_MASK;
2124 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2125 if (HeHASH(entry) != hash) /* strings can't be equal */
2127 if (HeKLEN(entry) != len)
2129 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2131 if (HeKFLAGS(entry) != flags_masked)
2139 if (--HeVAL(entry) == Nullsv) {
2140 *oentry = HeNEXT(entry);
2142 xhv->xhv_fill--; /* HvFILL(hv)-- */
2143 Safefree(HeKEY_hek(entry));
2145 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2149 UNLOCK_STRTAB_MUTEX;
2150 if (!found && ckWARN_d(WARN_INTERNAL))
2151 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2152 "Attempt to free non-existent shared string '%s'%s",
2153 hek ? HEK_KEY(hek) : str,
2154 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2155 if (k_flags & HVhek_FREEKEY)
2159 /* get a (constant) string ptr from the global string table
2160 * string will get added if it is not already there.
2161 * len and hash must both be valid for str.
2164 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2166 bool is_utf8 = FALSE;
2168 const char *save = str;
2171 STRLEN tmplen = -len;
2173 /* See the note in hv_fetch(). --jhi */
2174 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2176 /* If we were able to downgrade here, then than means that we were passed
2177 in a key which only had chars 0-255, but was utf8 encoded. */
2180 /* If we found we were able to downgrade the string to bytes, then
2181 we should flag that it needs upgrading on keys or each. Also flag
2182 that we need share_hek_flags to free the string. */
2184 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2187 return share_hek_flags (str, len, hash, flags);
2191 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2193 register XPVHV* xhv;
2195 register HE **oentry;
2198 int flags_masked = flags & HVhek_MASK;
2200 /* what follows is the moral equivalent of:
2202 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2203 hv_store(PL_strtab, str, len, Nullsv, hash);
2205 xhv = (XPVHV*)SvANY(PL_strtab);
2206 /* assert(xhv_array != 0) */
2208 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2209 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2210 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2211 if (HeHASH(entry) != hash) /* strings can't be equal */
2213 if (HeKLEN(entry) != len)
2215 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2217 if (HeKFLAGS(entry) != flags_masked)
2224 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2225 HeVAL(entry) = Nullsv;
2226 HeNEXT(entry) = *oentry;
2228 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2229 if (i) { /* initial entry? */
2230 xhv->xhv_fill++; /* HvFILL(hv)++ */
2231 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
2236 ++HeVAL(entry); /* use value slot as REFCNT */
2237 UNLOCK_STRTAB_MUTEX;
2239 if (flags & HVhek_FREEKEY)
2242 return HeKEY_hek(entry);