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 */),
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);
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);
444 key = (const char*)strupr((char*)key);
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);
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?-(I32)klen:klen, hash);
602 else /* gotta do the real thing */
603 HeKEY_hek(entry) = save_hek(key, is_utf8?-(I32)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) */)
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);
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) */)
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);
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, hv_fill;
1186 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1188 hv_max = HvMAX(ohv);
1190 if (!SvMAGICAL((SV *)ohv)) {
1191 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1192 int i, shared = !!HvSHAREKEYS(ohv);
1193 HE **ents, **oents = (HE **)HvARRAY(ohv);
1195 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1198 /* In each bucket... */
1199 for (i = 0; i <= hv_max; i++) {
1200 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1207 /* Copy the linked list of entries. */
1208 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1209 U32 hash = HeHASH(oent);
1210 char *key = HeKEY(oent);
1211 STRLEN len = HeKLEN_UTF8(oent);
1214 HeVAL(ent) = newSVsv(HeVAL(oent));
1215 HeKEY_hek(ent) = shared ? share_hek(key, len, hash)
1216 : save_hek(key, len, hash);
1227 HvFILL(hv) = hv_fill;
1228 HvKEYS(hv) = HvKEYS(ohv);
1232 /* Iterate over ohv, copying keys and values one at a time. */
1234 I32 riter = HvRITER(ohv);
1235 HE *eiter = HvEITER(ohv);
1237 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1238 while (hv_max && hv_max + 1 >= hv_fill * 2)
1239 hv_max = hv_max / 2;
1243 while ((entry = hv_iternext(ohv))) {
1244 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1245 newSVsv(HeVAL(entry)), HeHASH(entry));
1247 HvRITER(ohv) = riter;
1248 HvEITER(ohv) = eiter;
1255 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1262 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1263 PL_sub_generation++; /* may be deletion of method from stash */
1265 if (HeKLEN(entry) == HEf_SVKEY) {
1266 SvREFCNT_dec(HeKEY_sv(entry));
1267 Safefree(HeKEY_hek(entry));
1269 else if (HvSHAREKEYS(hv))
1270 unshare_hek(HeKEY_hek(entry));
1272 Safefree(HeKEY_hek(entry));
1277 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1281 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1282 PL_sub_generation++; /* may be deletion of method from stash */
1283 sv_2mortal(HeVAL(entry)); /* free between statements */
1284 if (HeKLEN(entry) == HEf_SVKEY) {
1285 sv_2mortal(HeKEY_sv(entry));
1286 Safefree(HeKEY_hek(entry));
1288 else if (HvSHAREKEYS(hv))
1289 unshare_hek(HeKEY_hek(entry));
1291 Safefree(HeKEY_hek(entry));
1296 =for apidoc hv_clear
1298 Clears a hash, making it empty.
1304 Perl_hv_clear(pTHX_ HV *hv)
1306 register XPVHV* xhv;
1309 xhv = (XPVHV*)SvANY(hv);
1311 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1312 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1313 if (xhv->xhv_array /* HvARRAY(hv) */)
1314 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1315 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1322 S_hfreeentries(pTHX_ HV *hv)
1324 register HE **array;
1326 register HE *oentry = Null(HE*);
1337 array = HvARRAY(hv);
1342 entry = HeNEXT(entry);
1343 hv_free_ent(hv, oentry);
1348 entry = array[riter];
1351 (void)hv_iterinit(hv);
1355 =for apidoc hv_undef
1363 Perl_hv_undef(pTHX_ HV *hv)
1365 register XPVHV* xhv;
1368 xhv = (XPVHV*)SvANY(hv);
1370 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1372 Safefree(HvNAME(hv));
1375 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1376 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1377 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1378 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1385 =for apidoc hv_iterinit
1387 Prepares a starting point to traverse a hash table. Returns the number of
1388 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1389 currently only meaningful for hashes without tie magic.
1391 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1392 hash buckets that happen to be in use. If you still need that esoteric
1393 value, you can get it through the macro C<HvFILL(tb)>.
1399 Perl_hv_iterinit(pTHX_ HV *hv)
1401 register XPVHV* xhv;
1405 Perl_croak(aTHX_ "Bad hash");
1406 xhv = (XPVHV*)SvANY(hv);
1407 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1408 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1410 hv_free_ent(hv, entry);
1412 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1413 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1414 /* used to be xhv->xhv_fill before 5.004_65 */
1415 return xhv->xhv_keys; /* HvKEYS(hv) */
1419 =for apidoc hv_iternext
1421 Returns entries from a hash iterator. See C<hv_iterinit>.
1427 Perl_hv_iternext(pTHX_ HV *hv)
1429 register XPVHV* xhv;
1435 Perl_croak(aTHX_ "Bad hash");
1436 xhv = (XPVHV*)SvANY(hv);
1437 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1439 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1440 SV *key = sv_newmortal();
1442 sv_setsv(key, HeSVKEY_force(entry));
1443 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1449 /* one HE per MAGICAL hash */
1450 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1452 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1454 HeKEY_hek(entry) = hek;
1455 HeKLEN(entry) = HEf_SVKEY;
1457 magic_nextpack((SV*) hv,mg,key);
1459 /* force key to stay around until next time */
1460 HeSVKEY_set(entry, SvREFCNT_inc(key));
1461 return entry; /* beware, hent_val is not set */
1464 SvREFCNT_dec(HeVAL(entry));
1465 Safefree(HeKEY_hek(entry));
1467 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1470 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1471 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1475 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1476 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1477 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1480 entry = HeNEXT(entry);
1482 xhv->xhv_riter++; /* HvRITER(hv)++ */
1483 if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1484 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1487 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1488 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1491 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1493 hv_free_ent(hv, oldentry);
1496 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1501 =for apidoc hv_iterkey
1503 Returns the key from the current position of the hash iterator. See
1510 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1512 if (HeKLEN(entry) == HEf_SVKEY) {
1514 char *p = SvPV(HeKEY_sv(entry), len);
1519 *retlen = HeKLEN(entry);
1520 return HeKEY(entry);
1524 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1526 =for apidoc hv_iterkeysv
1528 Returns the key as an C<SV*> from the current position of the hash
1529 iterator. The return value will always be a mortal copy of the key. Also
1536 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1538 if (HeKLEN(entry) == HEf_SVKEY)
1539 return sv_mortalcopy(HeKEY_sv(entry));
1541 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1542 HeKLEN_UTF8(entry), HeHASH(entry)));
1546 =for apidoc hv_iterval
1548 Returns the value from the current position of the hash iterator. See
1555 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1557 if (SvRMAGICAL(hv)) {
1558 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1559 SV* sv = sv_newmortal();
1560 if (HeKLEN(entry) == HEf_SVKEY)
1561 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1562 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1566 return HeVAL(entry);
1570 =for apidoc hv_iternextsv
1572 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1579 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1582 if ( (he = hv_iternext(hv)) == NULL)
1584 *key = hv_iterkey(he, retlen);
1585 return hv_iterval(hv, he);
1589 =for apidoc hv_magic
1591 Adds magic to a hash. See C<sv_magic>.
1597 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1599 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1603 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1605 return HEK_KEY(share_hek(sv, len, hash));
1608 /* possibly free a shared string if no one has access to it
1609 * len and hash must both be valid for str.
1612 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1614 register XPVHV* xhv;
1616 register HE **oentry;
1619 bool is_utf8 = FALSE;
1620 const char *save = str;
1623 STRLEN tmplen = -len;
1625 /* See the note in hv_fetch(). --jhi */
1626 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1630 /* what follows is the moral equivalent of:
1631 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1632 if (--*Svp == Nullsv)
1633 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1635 xhv = (XPVHV*)SvANY(PL_strtab);
1636 /* assert(xhv_array != 0) */
1638 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1639 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1640 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1641 if (HeHASH(entry) != hash) /* strings can't be equal */
1643 if (HeKLEN(entry) != len)
1645 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1647 if (HeKUTF8(entry) != (char)is_utf8)
1650 if (--HeVAL(entry) == Nullsv) {
1651 *oentry = HeNEXT(entry);
1653 xhv->xhv_fill--; /* HvFILL(hv)-- */
1654 Safefree(HeKEY_hek(entry));
1656 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1660 UNLOCK_STRTAB_MUTEX;
1663 if (!found && ckWARN_d(WARN_INTERNAL))
1664 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1667 /* get a (constant) string ptr from the global string table
1668 * string will get added if it is not already there.
1669 * len and hash must both be valid for str.
1672 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1674 register XPVHV* xhv;
1676 register HE **oentry;
1679 bool is_utf8 = FALSE;
1680 const char *save = str;
1683 STRLEN tmplen = -len;
1685 /* See the note in hv_fetch(). --jhi */
1686 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1690 /* what follows is the moral equivalent of:
1692 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1693 hv_store(PL_strtab, str, len, Nullsv, hash);
1695 xhv = (XPVHV*)SvANY(PL_strtab);
1696 /* assert(xhv_array != 0) */
1698 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1699 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1700 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1701 if (HeHASH(entry) != hash) /* strings can't be equal */
1703 if (HeKLEN(entry) != len)
1705 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1707 if (HeKUTF8(entry) != (char)is_utf8)
1714 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1715 HeVAL(entry) = Nullsv;
1716 HeNEXT(entry) = *oentry;
1718 xhv->xhv_keys++; /* HvKEYS(hv)++ */
1719 if (i) { /* initial entry? */
1720 xhv->xhv_fill++; /* HvFILL(hv)++ */
1721 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
1726 ++HeVAL(entry); /* use value slot as REFCNT */
1727 UNLOCK_STRTAB_MUTEX;
1730 return HeKEY_hek(entry);