3 * Copyright (c) 1991-2001, 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
26 PL_he_root = HeNEXT(he);
35 HeNEXT(p) = (HE*)PL_he_root;
46 New(54, ptr, 1008/sizeof(XPV), XPV);
47 ptr->xpv_pv = (char*)PL_he_arenaroot;
48 PL_he_arenaroot = ptr;
51 heend = &he[1008 / sizeof(HE) - 1];
54 HeNEXT(he) = (HE*)(he + 1);
62 #define new_HE() (HE*)safemalloc(sizeof(HE))
63 #define del_HE(p) safefree((char*)p)
67 #define new_HE() new_he()
68 #define del_HE(p) del_he(p)
73 S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
84 New(54, k, HEK_BASESIZE + len + 1, char);
86 Copy(str, HEK_KEY(hek), len, char);
89 HEK_UTF8(hek) = (char)is_utf8;
94 Perl_unshare_hek(pTHX_ HEK *hek)
96 unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
100 #if defined(USE_ITHREADS)
102 Perl_he_dup(pTHX_ HE *e, bool shared, clone_params* param)
108 /* look for it in the table first */
109 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
113 /* create anew and remember what it is */
115 ptr_table_store(PL_ptr_table, e, ret);
117 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
118 if (HeKLEN(e) == HEf_SVKEY)
119 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
121 HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
123 HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
124 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
127 #endif /* USE_ITHREADS */
129 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
135 Returns the SV which corresponds to the specified key in the hash. The
136 C<klen> is the length of the key. If C<lval> is set then the fetch will be
137 part of a store. Check that the return value is non-null before
138 dereferencing it to a C<SV*>.
140 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
141 information on how to use this function on tied hashes.
147 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
153 bool is_utf8 = FALSE;
154 const char *keysave = key;
164 if (SvRMAGICAL(hv)) {
165 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
167 mg_copy((SV*)hv, sv, key, klen);
169 return &PL_hv_fetch_sv;
171 #ifdef ENV_IS_CASELESS
172 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
174 for (i = 0; i < klen; ++i)
175 if (isLOWER(key[i])) {
176 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
177 SV **ret = hv_fetch(hv, nkey, klen, 0);
179 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
186 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
187 avoid unnecessary pointer dereferencing. */
188 xhv = (XPVHV*)SvANY(hv);
189 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
191 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
192 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
195 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
196 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
202 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
203 STRLEN tmplen = klen;
204 /* Just casting the &klen to (STRLEN) won't work well
205 * if STRLEN and I32 are of different widths. --jhi */
206 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
210 PERL_HASH(hash, key, klen);
212 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
213 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
214 for (; entry; entry = HeNEXT(entry)) {
215 if (HeHASH(entry) != hash) /* strings can't be equal */
217 if (HeKLEN(entry) != klen)
219 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
221 if (HeKUTF8(entry) != (char)is_utf8)
225 return &HeVAL(entry);
227 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
228 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
230 char *env = PerlEnv_ENVgetenv_len(key,&len);
232 sv = newSVpvn(env,len);
236 return hv_store(hv,key,klen,sv,hash);
240 if (lval) { /* gonna assign to this, so it better be there */
242 if (key != keysave) { /* must be is_utf8 == 0 */
243 SV **ret = hv_store(hv,key,klen,sv,hash);
248 return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
255 /* returns a HE * structure with the all fields set */
256 /* note that hent_val will be a mortal sv for MAGICAL hashes */
258 =for apidoc hv_fetch_ent
260 Returns the hash entry which corresponds to the specified key in the hash.
261 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
262 if you want the function to compute it. IF C<lval> is set then the fetch
263 will be part of a store. Make sure the return value is non-null before
264 accessing it. The return value when C<tb> is a tied hash is a pointer to a
265 static location, so be sure to make a copy of the structure if you need to
268 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
269 information on how to use this function on tied hashes.
275 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
288 if (SvRMAGICAL(hv)) {
289 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
291 keysv = sv_2mortal(newSVsv(keysv));
292 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
293 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
295 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
296 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
298 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
299 HeVAL(&PL_hv_fetch_ent_mh) = sv;
300 return &PL_hv_fetch_ent_mh;
302 #ifdef ENV_IS_CASELESS
303 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
305 key = SvPV(keysv, klen);
306 for (i = 0; i < klen; ++i)
307 if (isLOWER(key[i])) {
308 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
309 (void)strupr(SvPVX(nkeysv));
310 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
312 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
319 xhv = (XPVHV*)SvANY(hv);
320 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
322 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
323 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
326 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
327 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
333 keysave = key = SvPV(keysv, klen);
334 is_utf8 = (SvUTF8(keysv)!=0);
336 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
337 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
340 PERL_HASH(hash, key, klen);
342 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
343 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
344 for (; entry; entry = HeNEXT(entry)) {
345 if (HeHASH(entry) != hash) /* strings can't be equal */
347 if (HeKLEN(entry) != klen)
349 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
351 if (HeKUTF8(entry) != (char)is_utf8)
357 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
358 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
360 char *env = PerlEnv_ENVgetenv_len(key,&len);
362 sv = newSVpvn(env,len);
364 return hv_store_ent(hv,keysv,sv,hash);
370 if (lval) { /* gonna assign to this, so it better be there */
372 return hv_store_ent(hv,keysv,sv,hash);
378 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
380 MAGIC *mg = SvMAGIC(hv);
384 if (isUPPER(mg->mg_type)) {
386 switch (mg->mg_type) {
387 case PERL_MAGIC_tied:
389 *needs_store = FALSE;
392 mg = mg->mg_moremagic;
399 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
400 the length of the key. The C<hash> parameter is the precomputed hash
401 value; if it is zero then Perl will compute it. The return value will be
402 NULL if the operation failed or if the value did not need to be actually
403 stored within the hash (as in the case of tied hashes). Otherwise it can
404 be dereferenced to get the original C<SV*>. Note that the caller is
405 responsible for suitably incrementing the reference count of C<val> before
406 the call, and decrementing it if the function returned NULL.
408 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
409 information on how to use this function on tied hashes.
415 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
420 register HE **oentry;
421 bool is_utf8 = FALSE;
422 const char *keysave = key;
432 xhv = (XPVHV*)SvANY(hv);
436 hv_magic_check (hv, &needs_copy, &needs_store);
438 mg_copy((SV*)hv, val, key, klen);
439 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store)
441 #ifdef ENV_IS_CASELESS
442 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
443 key = savepvn(key,klen);
450 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
451 STRLEN tmplen = klen;
452 /* See the note in hv_fetch(). --jhi */
453 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
458 PERL_HASH(hash, key, klen);
460 if (!xhv->xhv_array /* !HvARRAY(hv) */)
461 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
462 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
465 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
466 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
469 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
470 if (HeHASH(entry) != hash) /* strings can't be equal */
472 if (HeKLEN(entry) != klen)
474 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
476 if (HeKUTF8(entry) != (char)is_utf8)
478 SvREFCNT_dec(HeVAL(entry));
482 return &HeVAL(entry);
487 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
488 else /* gotta do the real thing */
489 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
493 HeNEXT(entry) = *oentry;
496 xhv->xhv_keys++; /* HvKEYS(hv)++ */
497 if (i) { /* initial entry? */
498 xhv->xhv_fill++; /* HvFILL(hv)++ */
499 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
503 return &HeVAL(entry);
507 =for apidoc hv_store_ent
509 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
510 parameter is the precomputed hash value; if it is zero then Perl will
511 compute it. The return value is the new hash entry so created. It will be
512 NULL if the operation failed or if the value did not need to be actually
513 stored within the hash (as in the case of tied hashes). Otherwise the
514 contents of the return value can be accessed using the C<He?> macros
515 described here. Note that the caller is responsible for suitably
516 incrementing the reference count of C<val> before the call, and
517 decrementing it if the function returned NULL.
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_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
533 register HE **oentry;
540 xhv = (XPVHV*)SvANY(hv);
544 hv_magic_check (hv, &needs_copy, &needs_store);
546 bool save_taint = PL_tainted;
548 PL_tainted = SvTAINTED(keysv);
549 keysv = sv_2mortal(newSVsv(keysv));
550 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
551 TAINT_IF(save_taint);
552 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
554 #ifdef ENV_IS_CASELESS
555 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
556 key = SvPV(keysv, klen);
557 keysv = sv_2mortal(newSVpvn(key,klen));
558 (void)strupr(SvPVX(keysv));
565 keysave = key = SvPV(keysv, klen);
566 is_utf8 = (SvUTF8(keysv) != 0);
568 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
569 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
572 PERL_HASH(hash, key, klen);
574 if (!xhv->xhv_array /* !HvARRAY(hv) */)
575 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
576 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
579 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
580 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
583 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
584 if (HeHASH(entry) != hash) /* strings can't be equal */
586 if (HeKLEN(entry) != klen)
588 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
590 if (HeKUTF8(entry) != (char)is_utf8)
592 SvREFCNT_dec(HeVAL(entry));
601 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
602 else /* gotta do the real thing */
603 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
607 HeNEXT(entry) = *oentry;
610 xhv->xhv_keys++; /* HvKEYS(hv)++ */
611 if (i) { /* initial entry? */
612 xhv->xhv_fill++; /* HvFILL(hv)++ */
613 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
621 =for apidoc hv_delete
623 Deletes a key/value pair in the hash. The value SV is removed from the
624 hash and returned to the caller. The C<klen> is the length of the key.
625 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
632 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
638 register HE **oentry;
641 bool is_utf8 = FALSE;
642 const char *keysave = key;
650 if (SvRMAGICAL(hv)) {
653 hv_magic_check (hv, &needs_copy, &needs_store);
655 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
659 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
660 /* No longer an element */
661 sv_unmagic(sv, PERL_MAGIC_tiedelem);
664 return Nullsv; /* element cannot be deleted */
666 #ifdef ENV_IS_CASELESS
667 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
668 sv = sv_2mortal(newSVpvn(key,klen));
669 key = strupr(SvPVX(sv));
674 xhv = (XPVHV*)SvANY(hv);
675 if (!xhv->xhv_array /* !HvARRAY(hv) */)
678 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
679 STRLEN tmplen = klen;
680 /* See the note in hv_fetch(). --jhi */
681 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
685 PERL_HASH(hash, key, klen);
687 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
688 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
691 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
692 if (HeHASH(entry) != hash) /* strings can't be equal */
694 if (HeKLEN(entry) != klen)
696 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
698 if (HeKUTF8(entry) != (char)is_utf8)
702 *oentry = HeNEXT(entry);
704 xhv->xhv_fill--; /* HvFILL(hv)-- */
705 if (flags & G_DISCARD)
708 sv = sv_2mortal(HeVAL(entry));
709 HeVAL(entry) = &PL_sv_undef;
711 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
714 hv_free_ent(hv, entry);
715 xhv->xhv_keys--; /* HvKEYS(hv)-- */
724 =for apidoc hv_delete_ent
726 Deletes a key/value pair in the hash. The value SV is removed from the
727 hash and returned to the caller. The C<flags> value will normally be zero;
728 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
729 precomputed hash value, or 0 to ask for it to be computed.
735 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
742 register HE **oentry;
749 if (SvRMAGICAL(hv)) {
752 hv_magic_check (hv, &needs_copy, &needs_store);
754 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
758 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
759 /* No longer an element */
760 sv_unmagic(sv, PERL_MAGIC_tiedelem);
763 return Nullsv; /* element cannot be deleted */
765 #ifdef ENV_IS_CASELESS
766 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
767 key = SvPV(keysv, klen);
768 keysv = sv_2mortal(newSVpvn(key,klen));
769 (void)strupr(SvPVX(keysv));
775 xhv = (XPVHV*)SvANY(hv);
776 if (!xhv->xhv_array /* !HvARRAY(hv) */)
779 keysave = key = SvPV(keysv, klen);
780 is_utf8 = (SvUTF8(keysv) != 0);
782 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
783 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
786 PERL_HASH(hash, key, klen);
788 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
789 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
792 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
793 if (HeHASH(entry) != hash) /* strings can't be equal */
795 if (HeKLEN(entry) != klen)
797 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
799 if (HeKUTF8(entry) != (char)is_utf8)
803 *oentry = HeNEXT(entry);
805 xhv->xhv_fill--; /* HvFILL(hv)-- */
806 if (flags & G_DISCARD)
809 sv = sv_2mortal(HeVAL(entry));
810 HeVAL(entry) = &PL_sv_undef;
812 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
815 hv_free_ent(hv, entry);
816 xhv->xhv_keys--; /* HvKEYS(hv)-- */
825 =for apidoc hv_exists
827 Returns a boolean indicating whether the specified hash key exists. The
828 C<klen> is the length of the key.
834 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
840 bool is_utf8 = FALSE;
841 const char *keysave = key;
851 if (SvRMAGICAL(hv)) {
852 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
854 mg_copy((SV*)hv, sv, key, klen);
855 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
858 #ifdef ENV_IS_CASELESS
859 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
860 sv = sv_2mortal(newSVpvn(key,klen));
861 key = strupr(SvPVX(sv));
866 xhv = (XPVHV*)SvANY(hv);
867 #ifndef DYNAMIC_ENV_FETCH
868 if (!xhv->xhv_array /* !HvARRAY(hv) */)
872 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
873 STRLEN tmplen = klen;
874 /* See the note in hv_fetch(). --jhi */
875 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
879 PERL_HASH(hash, key, klen);
881 #ifdef DYNAMIC_ENV_FETCH
882 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
885 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
886 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
887 for (; entry; entry = HeNEXT(entry)) {
888 if (HeHASH(entry) != hash) /* strings can't be equal */
890 if (HeKLEN(entry) != klen)
892 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
894 if (HeKUTF8(entry) != (char)is_utf8)
900 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
901 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
903 char *env = PerlEnv_ENVgetenv_len(key,&len);
905 sv = newSVpvn(env,len);
907 (void)hv_store(hv,key,klen,sv,hash);
919 =for apidoc hv_exists_ent
921 Returns a boolean indicating whether the specified hash key exists. C<hash>
922 can be a valid precomputed hash value, or 0 to ask for it to be
929 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
942 if (SvRMAGICAL(hv)) {
943 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
944 SV* svret = sv_newmortal();
946 keysv = sv_2mortal(newSVsv(keysv));
947 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
948 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
949 return SvTRUE(svret);
951 #ifdef ENV_IS_CASELESS
952 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
953 key = SvPV(keysv, klen);
954 keysv = sv_2mortal(newSVpvn(key,klen));
955 (void)strupr(SvPVX(keysv));
961 xhv = (XPVHV*)SvANY(hv);
962 #ifndef DYNAMIC_ENV_FETCH
963 if (!xhv->xhv_array /* !HvARRAY(hv) */)
967 keysave = key = SvPV(keysv, klen);
968 is_utf8 = (SvUTF8(keysv) != 0);
969 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
970 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
972 PERL_HASH(hash, key, klen);
974 #ifdef DYNAMIC_ENV_FETCH
975 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
978 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
979 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
980 for (; entry; entry = HeNEXT(entry)) {
981 if (HeHASH(entry) != hash) /* strings can't be equal */
983 if (HeKLEN(entry) != klen)
985 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
987 if (HeKUTF8(entry) != (char)is_utf8)
993 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
994 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
996 char *env = PerlEnv_ENVgetenv_len(key,&len);
998 sv = newSVpvn(env,len);
1000 (void)hv_store_ent(hv,keysv,sv,hash);
1011 S_hsplit(pTHX_ HV *hv)
1013 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1014 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1015 register I32 newsize = oldsize * 2;
1017 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1021 register HE **oentry;
1024 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1025 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1031 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1036 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1037 if (oldsize >= 64) {
1038 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1039 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1042 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1046 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1047 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1048 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1051 for (i=0; i<oldsize; i++,aep++) {
1052 if (!*aep) /* non-existent */
1055 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1056 if ((HeHASH(entry) & newsize) != i) {
1057 *oentry = HeNEXT(entry);
1058 HeNEXT(entry) = *bep;
1060 xhv->xhv_fill++; /* HvFILL(hv)++ */
1065 oentry = &HeNEXT(entry);
1067 if (!*aep) /* everything moved */
1068 xhv->xhv_fill--; /* HvFILL(hv)-- */
1073 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1075 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1076 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1077 register I32 newsize;
1083 register HE **oentry;
1085 newsize = (I32) newmax; /* possible truncation here */
1086 if (newsize != newmax || newmax <= oldsize)
1088 while ((newsize & (1 + ~newsize)) != newsize) {
1089 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1091 if (newsize < newmax)
1093 if (newsize < newmax)
1094 return; /* overflow detection */
1096 a = xhv->xhv_array; /* HvARRAY(hv) */
1099 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1100 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1106 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1111 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1112 if (oldsize >= 64) {
1113 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1114 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1117 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1120 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1123 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1125 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1126 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1127 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1131 for (i=0; i<oldsize; i++,aep++) {
1132 if (!*aep) /* non-existent */
1134 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1135 if ((j = (HeHASH(entry) & newsize)) != i) {
1137 *oentry = HeNEXT(entry);
1138 if (!(HeNEXT(entry) = aep[j]))
1139 xhv->xhv_fill++; /* HvFILL(hv)++ */
1144 oentry = &HeNEXT(entry);
1146 if (!*aep) /* everything moved */
1147 xhv->xhv_fill--; /* HvFILL(hv)-- */
1154 Creates a new HV. The reference count is set to 1.
1163 register XPVHV* xhv;
1165 hv = (HV*)NEWSV(502,0);
1166 sv_upgrade((SV *)hv, SVt_PVHV);
1167 xhv = (XPVHV*)SvANY(hv);
1170 #ifndef NODEFAULT_SHAREKEYS
1171 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1173 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1174 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1175 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1176 (void)hv_iterinit(hv); /* so each() will start off right */
1181 Perl_newHVhv(pTHX_ HV *ohv)
1184 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1185 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1188 while (hv_max && hv_max + 1 >= hv_fill * 2)
1189 hv_max = hv_max / 2; /* Is always 2^n-1 */
1195 if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
1202 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
1203 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
1207 while ((entry = hv_iternext(ohv))) {
1208 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1209 newSVsv(HeVAL(entry)), HeHASH(entry));
1211 HvRITER(ohv) = hv_riter;
1212 HvEITER(ohv) = hv_eiter;
1219 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1226 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1227 PL_sub_generation++; /* may be deletion of method from stash */
1229 if (HeKLEN(entry) == HEf_SVKEY) {
1230 SvREFCNT_dec(HeKEY_sv(entry));
1231 Safefree(HeKEY_hek(entry));
1233 else if (HvSHAREKEYS(hv))
1234 unshare_hek(HeKEY_hek(entry));
1236 Safefree(HeKEY_hek(entry));
1241 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1245 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1246 PL_sub_generation++; /* may be deletion of method from stash */
1247 sv_2mortal(HeVAL(entry)); /* free between statements */
1248 if (HeKLEN(entry) == HEf_SVKEY) {
1249 sv_2mortal(HeKEY_sv(entry));
1250 Safefree(HeKEY_hek(entry));
1252 else if (HvSHAREKEYS(hv))
1253 unshare_hek(HeKEY_hek(entry));
1255 Safefree(HeKEY_hek(entry));
1260 =for apidoc hv_clear
1262 Clears a hash, making it empty.
1268 Perl_hv_clear(pTHX_ HV *hv)
1270 register XPVHV* xhv;
1273 xhv = (XPVHV*)SvANY(hv);
1275 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1276 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1277 if (xhv->xhv_array /* HvARRAY(hv) */)
1278 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1279 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1286 S_hfreeentries(pTHX_ HV *hv)
1288 register HE **array;
1290 register HE *oentry = Null(HE*);
1301 array = HvARRAY(hv);
1306 entry = HeNEXT(entry);
1307 hv_free_ent(hv, oentry);
1312 entry = array[riter];
1315 (void)hv_iterinit(hv);
1319 =for apidoc hv_undef
1327 Perl_hv_undef(pTHX_ HV *hv)
1329 register XPVHV* xhv;
1332 xhv = (XPVHV*)SvANY(hv);
1334 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1336 Safefree(HvNAME(hv));
1339 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1340 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1341 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1342 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1349 =for apidoc hv_iterinit
1351 Prepares a starting point to traverse a hash table. Returns the number of
1352 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1353 currently only meaningful for hashes without tie magic.
1355 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1356 hash buckets that happen to be in use. If you still need that esoteric
1357 value, you can get it through the macro C<HvFILL(tb)>.
1363 Perl_hv_iterinit(pTHX_ HV *hv)
1365 register XPVHV* xhv;
1369 Perl_croak(aTHX_ "Bad hash");
1370 xhv = (XPVHV*)SvANY(hv);
1371 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1372 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1374 hv_free_ent(hv, entry);
1376 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1377 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1378 /* used to be xhv->xhv_fill before 5.004_65 */
1379 return xhv->xhv_keys; /* HvKEYS(hv) */
1383 =for apidoc hv_iternext
1385 Returns entries from a hash iterator. See C<hv_iterinit>.
1391 Perl_hv_iternext(pTHX_ HV *hv)
1393 register XPVHV* xhv;
1399 Perl_croak(aTHX_ "Bad hash");
1400 xhv = (XPVHV*)SvANY(hv);
1401 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1403 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1404 SV *key = sv_newmortal();
1406 sv_setsv(key, HeSVKEY_force(entry));
1407 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1413 /* one HE per MAGICAL hash */
1414 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1416 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1418 HeKEY_hek(entry) = hek;
1419 HeKLEN(entry) = HEf_SVKEY;
1421 magic_nextpack((SV*) hv,mg,key);
1423 /* force key to stay around until next time */
1424 HeSVKEY_set(entry, SvREFCNT_inc(key));
1425 return entry; /* beware, hent_val is not set */
1428 SvREFCNT_dec(HeVAL(entry));
1429 Safefree(HeKEY_hek(entry));
1431 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1434 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1435 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1439 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1440 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1441 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1444 entry = HeNEXT(entry);
1446 xhv->xhv_riter++; /* HvRITER(hv)++ */
1447 if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1448 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1451 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1452 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1455 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1457 hv_free_ent(hv, oldentry);
1460 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1465 =for apidoc hv_iterkey
1467 Returns the key from the current position of the hash iterator. See
1474 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1476 if (HeKLEN(entry) == HEf_SVKEY) {
1478 char *p = SvPV(HeKEY_sv(entry), len);
1483 *retlen = HeKLEN(entry);
1484 return HeKEY(entry);
1488 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1490 =for apidoc hv_iterkeysv
1492 Returns the key as an C<SV*> from the current position of the hash
1493 iterator. The return value will always be a mortal copy of the key. Also
1500 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1502 if (HeKLEN(entry) == HEf_SVKEY)
1503 return sv_mortalcopy(HeKEY_sv(entry));
1505 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1506 HeKLEN_UTF8(entry), HeHASH(entry)));
1510 =for apidoc hv_iterval
1512 Returns the value from the current position of the hash iterator. See
1519 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1521 if (SvRMAGICAL(hv)) {
1522 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1523 SV* sv = sv_newmortal();
1524 if (HeKLEN(entry) == HEf_SVKEY)
1525 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1526 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1530 return HeVAL(entry);
1534 =for apidoc hv_iternextsv
1536 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1543 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1546 if ( (he = hv_iternext(hv)) == NULL)
1548 *key = hv_iterkey(he, retlen);
1549 return hv_iterval(hv, he);
1553 =for apidoc hv_magic
1555 Adds magic to a hash. See C<sv_magic>.
1561 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1563 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1567 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1569 return HEK_KEY(share_hek(sv, len, hash));
1572 /* possibly free a shared string if no one has access to it
1573 * len and hash must both be valid for str.
1576 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1578 register XPVHV* xhv;
1580 register HE **oentry;
1583 bool is_utf8 = FALSE;
1584 const char *save = str;
1589 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1590 STRLEN tmplen = len;
1591 /* See the note in hv_fetch(). --jhi */
1592 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1597 /* what follows is the moral equivalent of:
1598 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1599 if (--*Svp == Nullsv)
1600 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1602 xhv = (XPVHV*)SvANY(PL_strtab);
1603 /* assert(xhv_array != 0) */
1605 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1606 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1607 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1608 if (HeHASH(entry) != hash) /* strings can't be equal */
1610 if (HeKLEN(entry) != len)
1612 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1614 if (HeKUTF8(entry) != (char)is_utf8)
1617 if (--HeVAL(entry) == Nullsv) {
1618 *oentry = HeNEXT(entry);
1620 xhv->xhv_fill--; /* HvFILL(hv)-- */
1621 Safefree(HeKEY_hek(entry));
1623 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1627 UNLOCK_STRTAB_MUTEX;
1630 if (!found && ckWARN_d(WARN_INTERNAL))
1631 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1634 /* get a (constant) string ptr from the global string table
1635 * string will get added if it is not already there.
1636 * len and hash must both be valid for str.
1639 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1641 register XPVHV* xhv;
1643 register HE **oentry;
1646 bool is_utf8 = FALSE;
1647 const char *save = str;
1652 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1653 STRLEN tmplen = len;
1654 /* See the note in hv_fetch(). --jhi */
1655 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1660 /* what follows is the moral equivalent of:
1662 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1663 hv_store(PL_strtab, str, len, Nullsv, hash);
1665 xhv = (XPVHV*)SvANY(PL_strtab);
1666 /* assert(xhv_array != 0) */
1668 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1669 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1670 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1671 if (HeHASH(entry) != hash) /* strings can't be equal */
1673 if (HeKLEN(entry) != len)
1675 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1677 if (HeKUTF8(entry) != (char)is_utf8)
1684 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1685 HeVAL(entry) = Nullsv;
1686 HeNEXT(entry) = *oentry;
1688 xhv->xhv_keys++; /* HvKEYS(hv)++ */
1689 if (i) { /* initial entry? */
1690 xhv->xhv_fill++; /* HvFILL(hv)++ */
1691 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
1696 ++HeVAL(entry); /* use value slot as REFCNT */
1697 UNLOCK_STRTAB_MUTEX;
1700 return HeKEY_hek(entry);