/* hv.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* "I sit beside the fire and think of all that I have seen." --Bilbo
*/
+/*
+=head1 Hash Manipulation Functions
+*/
+
#include "EXTERN.h"
#define PERL_IN_HV_C
#include "perl.h"
HE* he;
LOCK_SV_MUTEX;
if (!PL_he_root)
- more_he();
+ more_he();
he = PL_he_root;
PL_he_root = HeNEXT(he);
UNLOCK_SV_MUTEX;
{
register HE* he;
register HE* heend;
- New(54, PL_he_root, 1008/sizeof(HE), HE);
- he = PL_he_root;
+ XPV *ptr;
+ New(54, ptr, 1008/sizeof(XPV), XPV);
+ ptr->xpv_pv = (char*)PL_he_arenaroot;
+ PL_he_arenaroot = ptr;
+
+ he = (HE*)ptr;
heend = &he[1008 / sizeof(HE) - 1];
+ PL_he_root = ++he;
while (he < heend) {
- HeNEXT(he) = (HE*)(he + 1);
- he++;
+ HeNEXT(he) = (HE*)(he + 1);
+ he++;
}
HeNEXT(he) = 0;
}
#endif
STATIC HEK *
-S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
+S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
char *k;
register HEK *hek;
-
- New(54, k, HEK_BASESIZE + len + 1, char);
+
+ New(54, k, HEK_BASESIZE + len + 2, char);
hek = (HEK*)k;
Copy(str, HEK_KEY(hek), len, char);
- *(HEK_KEY(hek) + len) = '\0';
+ HEK_KEY(hek)[len] = 0;
HEK_LEN(hek) = len;
HEK_HASH(hek) = hash;
+ HEK_FLAGS(hek) = (unsigned char)flags;
return hek;
}
-void
-Perl_unshare_hek(pTHX_ HEK *hek)
-{
- unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
-}
-
#if defined(USE_ITHREADS)
HE *
-Perl_he_dup(pTHX_ HE *e, bool shared)
+Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
{
HE *ret;
ret = new_HE();
ptr_table_store(PL_ptr_table, e, ret);
- HeNEXT(ret) = he_dup(HeNEXT(e),shared);
+ HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
if (HeKLEN(e) == HEf_SVKEY)
- HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
+ HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
else if (shared)
- HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+ HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
+ HeKFLAGS(e));
else
- HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
- HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
+ HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
+ HeKFLAGS(e));
+ HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
return ret;
}
#endif /* USE_ITHREADS */
+static void
+S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
+ const char *msg)
+{
+ SV *sv = sv_newmortal(), *esv = sv_newmortal();
+ if (!(flags & HVhek_FREEKEY)) {
+ sv_setpvn(sv, key, klen);
+ }
+ else {
+ /* Need to free saved eventually assign to mortal SV */
+ SV *sv = sv_newmortal();
+ sv_usepvn(sv, (char *) key, klen);
+ }
+ if (flags & HVhek_UTF8) {
+ SvUTF8_on(sv);
+ }
+ Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
+ Perl_croak(aTHX_ SvPVX(esv), sv);
+}
+
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
* contains an SV* */
Returns the SV which corresponds to the specified key in the hash. The
C<klen> is the length of the key. If C<lval> is set then the fetch will be
part of a store. Check that the return value is non-null before
-dereferencing it to a C<SV*>.
+dereferencing it to an C<SV*>.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
=cut
*/
+
+SV**
+Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
+{
+ bool is_utf8 = FALSE;
+ const char *keysave = key;
+ int flags = 0;
+
+ if (klen < 0) {
+ klen = -klen;
+ is_utf8 = TRUE;
+ }
+
+ if (is_utf8) {
+ STRLEN tmplen = klen;
+ /* Just casting the &klen to (STRLEN) won't work well
+ * if STRLEN and I32 are of different widths. --jhi */
+ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
+ klen = tmplen;
+ /* If we were able to downgrade here, then than means that we were
+ passed in a key which only had chars 0-255, but was utf8 encoded. */
+ if (is_utf8)
+ flags = HVhek_UTF8;
+ /* If we found we were able to downgrade the string to bytes, then
+ we should flag that it needs upgrading on keys or each. */
+ if (key != keysave)
+ flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
+
+ return hv_fetch_flags (hv, key, klen, lval, flags);
+}
+
SV**
-Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
+S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
{
register XPVHV* xhv;
register U32 hash;
return 0;
if (SvRMAGICAL(hv)) {
- if (mg_find((SV*)hv,'P')) {
- dTHR;
+ /* All this clause seems to be utf8 unaware.
+ By moving the utf8 stuff out to hv_fetch_flags I need to ensure
+ key doesn't leak. I've not tried solving the utf8-ness.
+ NWC.
+ */
+ if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
PL_hv_fetch_sv = sv;
return &PL_hv_fetch_sv;
}
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
U32 i;
for (i = 0; i < klen; ++i)
if (isLOWER(key[i])) {
char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
SV **ret = hv_fetch(hv, nkey, klen, 0);
- if (!ret && lval)
- ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
+ if (!ret && lval) {
+ ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
+ flags);
+ } else if (flags & HVhek_FREEKEY)
+ Safefree(key);
return ret;
}
}
#endif
}
+ /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
+ avoid unnecessary pointer dereferencing. */
xhv = (XPVHV*)SvANY(hv);
- if (!xhv->xhv_array) {
- if (lval
+ if (!xhv->xhv_array /* !HvARRAY(hv) */) {
+ if (lval
#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
- || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
+ || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
#endif
- )
- Newz(503, xhv->xhv_array,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
- else
+ )
+ Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
+ char);
+ else {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
return 0;
+ }
}
PERL_HASH(hash, key, klen);
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
+ flags is 1 if utf8. need HeKFLAGS(entry) also 1.
+ xor is true if bits differ, in which case this isn't a match. */
+ if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
continue;
+ if (lval && HeKFLAGS(entry) != flags) {
+ /* We match if HVhek_UTF8 bit in our flags and hash key's match.
+ But if entry was set previously with HVhek_WASUTF8 and key now
+ doesn't (or vice versa) then we should change the key's flag,
+ as this is assignment. */
+ if (HvSHAREKEYS(hv)) {
+ /* Need to swap the key we have for a key with the flags we
+ need. As keys are shared we can't just write to the flag,
+ so we share the new one, unshare the old one. */
+ int flags_nofree = flags & ~HVhek_FREEKEY;
+ HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
+ unshare_hek (HeKEY_hek(entry));
+ HeKEY_hek(entry) = new_hek;
+ }
+ else
+ HeKFLAGS(entry) = flags;
+ }
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+ /* if we find a placeholder, we pretend we haven't found anything */
+ if (HeVAL(entry) == &PL_sv_undef)
+ break;
return &HeVAL(entry);
+
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
- if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
+ if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
return hv_store(hv,key,klen,sv,hash);
}
}
#endif
+ if (!entry && SvREADONLY(hv)) {
+ S_hv_notallowed(aTHX_ flags, key, klen,
+ "access disallowed key '%"SVf"' in"
+ );
+ }
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
- return hv_store(hv,key,klen,sv,hash);
+ return hv_store_flags(hv,key,klen,sv,hash,flags);
}
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
return 0;
}
-/* returns a HE * structure with the all fields set */
+/* returns an HE * structure with the all fields set */
/* note that hent_val will be a mortal sv for MAGICAL hashes */
/*
=for apidoc hv_fetch_ent
will be part of a store. Make sure the return value is non-null before
accessing it. The return value when C<tb> is a tied hash is a pointer to a
static location, so be sure to make a copy of the structure if you need to
-store it somewhere.
+store it somewhere.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
STRLEN klen;
register HE *entry;
SV *sv;
+ bool is_utf8;
+ int flags = 0;
+ char *keysave;
if (!hv)
return 0;
if (SvRMAGICAL(hv)) {
- if (mg_find((SV*)hv,'P')) {
- dTHR;
+ if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
return &PL_hv_fetch_ent_mh;
}
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
U32 i;
key = SvPV(keysv, klen);
for (i = 0; i < klen; ++i)
}
xhv = (XPVHV*)SvANY(hv);
- if (!xhv->xhv_array) {
- if (lval
+ if (!xhv->xhv_array /* !HvARRAY(hv) */) {
+ if (lval
#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
- || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
+ || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
#endif
- )
- Newz(503, xhv->xhv_array,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ )
+ Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
+ char);
else
return 0;
}
- key = SvPV(keysv, klen);
-
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv)!=0);
+
+ if (is_utf8) {
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+ if (is_utf8)
+ flags = HVhek_UTF8;
+ if (key != keysave)
+ flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
+
if (!hash)
PERL_HASH(hash, key, klen);
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
+ if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
+ continue;
+ if (lval && HeKFLAGS(entry) != flags) {
+ /* We match if HVhek_UTF8 bit in our flags and hash key's match.
+ But if entry was set previously with HVhek_WASUTF8 and key now
+ doesn't (or vice versa) then we should change the key's flag,
+ as this is assignment. */
+ if (HvSHAREKEYS(hv)) {
+ /* Need to swap the key we have for a key with the flags we
+ need. As keys are shared we can't just write to the flag,
+ so we share the new one, unshare the old one. */
+ int flags_nofree = flags & ~HVhek_FREEKEY;
+ HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
+ unshare_hek (HeKEY_hek(entry));
+ HeKEY_hek(entry) = new_hek;
+ }
+ else
+ HeKFLAGS(entry) = flags;
+ }
+ if (key != keysave)
+ Safefree(key);
+ /* if we find a placeholder, we pretend we haven't found anything */
+ if (HeVAL(entry) == &PL_sv_undef)
+ break;
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
- if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
+ if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
}
}
#endif
+ if (!entry && SvREADONLY(hv)) {
+ S_hv_notallowed(aTHX_ flags, key, klen,
+ "access disallowed key '%"SVf"' in"
+ );
+ }
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
return hv_store_ent(hv,keysv,sv,hash);
if (isUPPER(mg->mg_type)) {
*needs_copy = TRUE;
switch (mg->mg_type) {
- case 'P':
- case 'S':
+ case PERL_MAGIC_tied:
+ case PERL_MAGIC_sig:
*needs_store = FALSE;
}
}
stored within the hash (as in the case of tied hashes). Otherwise it can
be dereferenced to get the original C<SV*>. Note that the caller is
responsible for suitably incrementing the reference count of C<val> before
-the call, and decrementing it if the function returned NULL.
+the call, and decrementing it if the function returned NULL.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
*/
SV**
-Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
+Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
+{
+ bool is_utf8 = FALSE;
+ const char *keysave = key;
+ int flags = 0;
+
+ if (klen < 0) {
+ klen = -klen;
+ is_utf8 = TRUE;
+ }
+
+ if (is_utf8) {
+ STRLEN tmplen = klen;
+ /* Just casting the &klen to (STRLEN) won't work well
+ * if STRLEN and I32 are of different widths. --jhi */
+ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
+ klen = tmplen;
+ /* If we were able to downgrade here, then than means that we were
+ passed in a key which only had chars 0-255, but was utf8 encoded. */
+ if (is_utf8)
+ flags = HVhek_UTF8;
+ /* If we found we were able to downgrade the string to bytes, then
+ we should flag that it needs upgrading on keys or each. */
+ if (key != keysave)
+ flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
+
+ return hv_store_flags (hv, key, klen, val, hash, flags);
+}
+
+SV**
+Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
+ register U32 hash, int flags)
{
register XPVHV* xhv;
register I32 i;
hv_magic_check (hv, &needs_copy, &needs_store);
if (needs_copy) {
mg_copy((SV*)hv, val, key, klen);
- if (!xhv->xhv_array && !needs_store)
+ if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
return 0;
+ }
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
- SV *sv = sv_2mortal(newSVpvn(key,klen));
- key = strupr(SvPVX(sv));
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+ key = savepvn(key,klen);
+ key = (const char*)strupr((char*)key);
hash = 0;
}
#endif
}
}
+
+ if (flags)
+ HvHASKFLAGS_on((SV*)hv);
+
if (!hash)
PERL_HASH(hash, key, klen);
- if (!xhv->xhv_array)
- Newz(505, xhv->xhv_array,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ if (!xhv->xhv_array /* !HvARRAY(hv) */)
+ Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
+ char);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- SvREFCNT_dec(HeVAL(entry));
- HeVAL(entry) = val;
+ if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
+ continue;
+ if (HeVAL(entry) == &PL_sv_undef)
+ xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
+ else
+ SvREFCNT_dec(HeVAL(entry));
+ if (flags & HVhek_PLACEHOLD) {
+ /* We have been requested to insert a placeholder. Currently
+ only Storable is allowed to do this. */
+ xhv->xhv_placeholders++;
+ HeVAL(entry) = &PL_sv_undef;
+ } else
+ HeVAL(entry) = val;
+
+ if (HeKFLAGS(entry) != flags) {
+ /* We match if HVhek_UTF8 bit in our flags and hash key's match.
+ But if entry was set previously with HVhek_WASUTF8 and key now
+ doesn't (or vice versa) then we should change the key's flag,
+ as this is assignment. */
+ if (HvSHAREKEYS(hv)) {
+ /* Need to swap the key we have for a key with the flags we
+ need. As keys are shared we can't just write to the flag,
+ so we share the new one, unshare the old one. */
+ int flags_nofree = flags & ~HVhek_FREEKEY;
+ HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
+ unshare_hek (HeKEY_hek(entry));
+ HeKEY_hek(entry) = new_hek;
+ }
+ else
+ HeKFLAGS(entry) = flags;
+ }
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
return &HeVAL(entry);
}
+ if (SvREADONLY(hv)) {
+ S_hv_notallowed(aTHX_ flags, key, klen,
+ "access disallowed key '%"SVf"' to"
+ );
+ }
+
entry = new_HE();
+ /* share_hek_flags will do the free for us. This might be considered
+ bad API design. */
if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, klen, hash);
+ HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
else /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek(key, klen, hash);
- HeVAL(entry) = val;
+ HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
+ if (flags & HVhek_PLACEHOLD) {
+ /* We have been requested to insert a placeholder. Currently
+ only Storable is allowed to do this. */
+ xhv->xhv_placeholders++;
+ HeVAL(entry) = &PL_sv_undef;
+ } else
+ HeVAL(entry) = val;
HeNEXT(entry) = *oentry;
*oentry = entry;
- xhv->xhv_keys++;
+ xhv->xhv_keys++; /* HvKEYS(hv)++ */
if (i) { /* initial entry? */
- ++xhv->xhv_fill;
- if (xhv->xhv_keys > xhv->xhv_max)
+ xhv->xhv_fill++; /* HvFILL(hv)++ */
+ if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
hsplit(hv);
}
compute it. The return value is the new hash entry so created. It will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise the
-contents of the return value can be accessed using the C<He???> macros
+contents of the return value can be accessed using the C<He?> macros
described here. Note that the caller is responsible for suitably
incrementing the reference count of C<val> before the call, and
-decrementing it if the function returned NULL.
+decrementing it if the function returned NULL.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
*/
HE *
-Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
+Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
{
- register XPVHV* xhv;
- register char *key;
+ XPVHV* xhv;
+ char *key;
STRLEN klen;
- register I32 i;
- register HE *entry;
- register HE **oentry;
+ I32 i;
+ HE *entry;
+ HE **oentry;
+ bool is_utf8;
+ int flags = 0;
+ char *keysave;
if (!hv)
return 0;
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
- dTHR;
- bool needs_copy;
- bool needs_store;
- hv_magic_check (hv, &needs_copy, &needs_store);
- if (needs_copy) {
- bool save_taint = PL_tainted;
- if (PL_tainting)
- PL_tainted = SvTAINTED(keysv);
- keysv = sv_2mortal(newSVsv(keysv));
- mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
- TAINT_IF(save_taint);
- if (!xhv->xhv_array && !needs_store)
- return Nullhe;
+ bool needs_copy;
+ bool needs_store;
+ hv_magic_check (hv, &needs_copy, &needs_store);
+ if (needs_copy) {
+ bool save_taint = PL_tainted;
+ if (PL_tainting)
+ PL_tainted = SvTAINTED(keysv);
+ keysv = sv_2mortal(newSVsv(keysv));
+ mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
+ TAINT_IF(save_taint);
+ if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
+ return Nullhe;
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
}
}
- key = SvPV(keysv, klen);
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
+
+ if (is_utf8) {
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+ if (is_utf8)
+ flags = HVhek_UTF8;
+ if (key != keysave)
+ flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ HvHASKFLAGS_on((SV*)hv);
+ }
if (!hash)
PERL_HASH(hash, key, klen);
- if (!xhv->xhv_array)
- Newz(505, xhv->xhv_array,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ if (!xhv->xhv_array /* !HvARRAY(hv) */)
+ Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
+ char);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
-
- for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
+ entry = *oentry;
+ for (; entry; i=0, entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- SvREFCNT_dec(HeVAL(entry));
+ if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
+ continue;
+ if (HeVAL(entry) == &PL_sv_undef)
+ xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
+ else
+ SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
+ if (HeKFLAGS(entry) != flags) {
+ /* We match if HVhek_UTF8 bit in our flags and hash key's match.
+ But if entry was set previously with HVhek_WASUTF8 and key now
+ doesn't (or vice versa) then we should change the key's flag,
+ as this is assignment. */
+ if (HvSHAREKEYS(hv)) {
+ /* Need to swap the key we have for a key with the flags we
+ need. As keys are shared we can't just write to the flag,
+ so we share the new one, unshare the old one. */
+ int flags_nofree = flags & ~HVhek_FREEKEY;
+ HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
+ unshare_hek (HeKEY_hek(entry));
+ HeKEY_hek(entry) = new_hek;
+ }
+ else
+ HeKFLAGS(entry) = flags;
+ }
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
return entry;
}
+ if (SvREADONLY(hv)) {
+ S_hv_notallowed(aTHX_ flags, key, klen,
+ "access disallowed key '%"SVf"' to"
+ );
+ }
+
entry = new_HE();
+ /* share_hek_flags will do the free for us. This might be considered
+ bad API design. */
if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, klen, hash);
+ HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
else /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek(key, klen, hash);
+ HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
HeVAL(entry) = val;
HeNEXT(entry) = *oentry;
*oentry = entry;
- xhv->xhv_keys++;
+ xhv->xhv_keys++; /* HvKEYS(hv)++ */
if (i) { /* initial entry? */
- ++xhv->xhv_fill;
- if (xhv->xhv_keys > xhv->xhv_max)
+ xhv->xhv_fill++; /* HvFILL(hv)++ */
+ if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
hsplit(hv);
}
=for apidoc hv_delete
Deletes a key/value pair in the hash. The value SV is removed from the
-hash and returned to the caller. The C<klen> is the length of the key.
+hash and returned to the caller. The C<klen> is the length of the key.
The C<flags> value will normally be zero; if set to G_DISCARD then NULL
will be returned.
*/
SV *
-Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
+Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
{
register XPVHV* xhv;
register I32 i;
register HE **oentry;
SV **svp;
SV *sv;
+ bool is_utf8 = FALSE;
+ int k_flags = 0;
+ const char *keysave = key;
if (!hv)
return Nullsv;
+ if (klen < 0) {
+ klen = -klen;
+ is_utf8 = TRUE;
+ }
if (SvRMAGICAL(hv)) {
bool needs_copy;
bool needs_store;
sv = *svp;
mg_clear(sv);
if (!needs_store) {
- if (mg_find(sv, 'p')) {
- sv_unmagic(sv, 'p'); /* No longer an element */
+ if (mg_find(sv, PERL_MAGIC_tiedelem)) {
+ /* No longer an element */
+ sv_unmagic(sv, PERL_MAGIC_tiedelem);
return sv;
}
return Nullsv; /* element cannot be deleted */
}
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
sv = sv_2mortal(newSVpvn(key,klen));
key = strupr(SvPVX(sv));
}
#endif
- }
+ }
}
xhv = (XPVHV*)SvANY(hv);
- if (!xhv->xhv_array)
+ if (!xhv->xhv_array /* !HvARRAY(hv) */)
return Nullsv;
+ if (is_utf8) {
+ STRLEN tmplen = klen;
+ /* See the note in hv_fetch(). --jhi */
+ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
+ klen = tmplen;
+ if (is_utf8)
+ k_flags = HVhek_UTF8;
+ if (key != keysave)
+ k_flags |= HVhek_FREEKEY;
+ }
+
PERL_HASH(hash, key, klen);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--;
+ if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
+ continue;
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
+ /* if placeholder is here, it's already been deleted.... */
+ if (HeVAL(entry) == &PL_sv_undef)
+ {
+ if (SvREADONLY(hv))
+ return Nullsv; /* if still SvREADONLY, leave it deleted. */
+ else {
+ /* okay, really delete the placeholder... */
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
+ if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ if (xhv->xhv_keys == 0)
+ HvHASKFLAGS_off(hv);
+ xhv->xhv_placeholders--;
+ return Nullsv;
+ }
+ }
+ else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ S_hv_notallowed(aTHX_ k_flags, key, klen,
+ "delete readonly key '%"SVf"' from"
+ );
+ }
+
if (flags & G_DISCARD)
sv = Nullsv;
else {
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
- if (entry == xhv->xhv_eiter)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- --xhv->xhv_keys;
+
+ /*
+ * If a restricted hash, rather than really deleting the entry, put
+ * a placeholder there. This marks the key as being "approved", so
+ * we can still access via not-really-existing key without raising
+ * an error.
+ */
+ if (SvREADONLY(hv)) {
+ HeVAL(entry) = &PL_sv_undef;
+ /* We'll be saving this slot, so the number of allocated keys
+ * doesn't go down, but the number placeholders goes up */
+ xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+ } else {
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
+ if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ if (xhv->xhv_keys == 0)
+ HvHASKFLAGS_off(hv);
+ }
return sv;
}
+ if (SvREADONLY(hv)) {
+ S_hv_notallowed(aTHX_ k_flags, key, klen,
+ "access disallowed key '%"SVf"' from"
+ );
+ }
+
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
return Nullsv;
}
register HE *entry;
register HE **oentry;
SV *sv;
-
+ bool is_utf8;
+ int k_flags = 0;
+ char *keysave;
+
if (!hv)
return Nullsv;
if (SvRMAGICAL(hv)) {
sv = HeVAL(entry);
mg_clear(sv);
if (!needs_store) {
- if (mg_find(sv, 'p')) {
- sv_unmagic(sv, 'p'); /* No longer an element */
+ if (mg_find(sv, PERL_MAGIC_tiedelem)) {
+ /* No longer an element */
+ sv_unmagic(sv, PERL_MAGIC_tiedelem);
return sv;
}
return Nullsv; /* element cannot be deleted */
}
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
- hash = 0;
+ hash = 0;
}
#endif
}
}
xhv = (XPVHV*)SvANY(hv);
- if (!xhv->xhv_array)
+ if (!xhv->xhv_array /* !HvARRAY(hv) */)
return Nullsv;
- key = SvPV(keysv, klen);
-
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
+
+ if (is_utf8) {
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+ if (is_utf8)
+ k_flags = HVhek_UTF8;
+ if (key != keysave)
+ k_flags |= HVhek_FREEKEY;
+ }
+
if (!hash)
PERL_HASH(hash, key, klen);
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
continue;
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--;
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
+
+ /* if placeholder is here, it's already been deleted.... */
+ if (HeVAL(entry) == &PL_sv_undef)
+ {
+ if (SvREADONLY(hv))
+ return Nullsv; /* if still SvREADONLY, leave it deleted. */
+
+ /* okay, really delete the placeholder. */
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
+ if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ if (xhv->xhv_keys == 0)
+ HvHASKFLAGS_off(hv);
+ xhv->xhv_placeholders--;
+ return Nullsv;
+ }
+ else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ S_hv_notallowed(aTHX_ k_flags, key, klen,
+ "delete readonly key '%"SVf"' from"
+ );
+ }
+
if (flags & G_DISCARD)
sv = Nullsv;
else {
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
- if (entry == xhv->xhv_eiter)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- --xhv->xhv_keys;
+
+ /*
+ * If a restricted hash, rather than really deleting the entry, put
+ * a placeholder there. This marks the key as being "approved", so
+ * we can still access via not-really-existing key without raising
+ * an error.
+ */
+ if (SvREADONLY(hv)) {
+ HeVAL(entry) = &PL_sv_undef;
+ /* We'll be saving this slot, so the number of allocated keys
+ * doesn't go down, but the number placeholders goes up */
+ xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+ } else {
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
+ if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ if (xhv->xhv_keys == 0)
+ HvHASKFLAGS_off(hv);
+ }
return sv;
}
+ if (SvREADONLY(hv)) {
+ S_hv_notallowed(aTHX_ k_flags, key, klen,
+ "delete disallowed key '%"SVf"' from"
+ );
+ }
+
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
return Nullsv;
}
*/
bool
-Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
+Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
{
register XPVHV* xhv;
register U32 hash;
register HE *entry;
SV *sv;
+ bool is_utf8 = FALSE;
+ const char *keysave = key;
+ int k_flags = 0;
if (!hv)
return 0;
+ if (klen < 0) {
+ klen = -klen;
+ is_utf8 = TRUE;
+ }
+
if (SvRMAGICAL(hv)) {
- if (mg_find((SV*)hv,'P')) {
- dTHR;
+ if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
- mg_copy((SV*)hv, sv, key, klen);
- magic_existspack(sv, mg_find(sv, 'p'));
+ mg_copy((SV*)hv, sv, key, klen);
+ magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
return SvTRUE(sv);
}
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
sv = sv_2mortal(newSVpvn(key,klen));
key = strupr(SvPVX(sv));
}
xhv = (XPVHV*)SvANY(hv);
#ifndef DYNAMIC_ENV_FETCH
- if (!xhv->xhv_array)
- return 0;
+ if (!xhv->xhv_array /* !HvARRAY(hv) */)
+ return 0;
#endif
+ if (is_utf8) {
+ STRLEN tmplen = klen;
+ /* See the note in hv_fetch(). --jhi */
+ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
+ klen = tmplen;
+ if (is_utf8)
+ k_flags = HVhek_UTF8;
+ if (key != keysave)
+ k_flags |= HVhek_FREEKEY;
+ }
+
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
- if (!xhv->xhv_array) entry = Null(HE*);
+ if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
else
#endif
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
+ if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
+ continue;
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
+ /* If we find the key, but the value is a placeholder, return false. */
+ if (HeVAL(entry) == &PL_sv_undef)
+ return FALSE;
+
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
- if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
+ if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
(void)hv_store(hv,key,klen,sv,hash);
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
return TRUE;
}
}
#endif
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
return FALSE;
}
STRLEN klen;
register HE *entry;
SV *sv;
+ bool is_utf8;
+ char *keysave;
+ int k_flags = 0;
if (!hv)
return 0;
if (SvRMAGICAL(hv)) {
- if (mg_find((SV*)hv,'P')) {
- dTHR; /* just for SvTRUE */
+ if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
+ SV* svret = sv_newmortal();
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
- mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
- magic_existspack(sv, mg_find(sv, 'p'));
- return SvTRUE(sv);
+ mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+ magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
+ return SvTRUE(svret);
}
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
key = SvPV(keysv, klen);
keysv = sv_2mortal(newSVpvn(key,klen));
(void)strupr(SvPVX(keysv));
- hash = 0;
+ hash = 0;
}
#endif
}
xhv = (XPVHV*)SvANY(hv);
#ifndef DYNAMIC_ENV_FETCH
- if (!xhv->xhv_array)
- return 0;
+ if (!xhv->xhv_array /* !HvARRAY(hv) */)
+ return 0;
#endif
- key = SvPV(keysv, klen);
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
+ if (is_utf8) {
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+ if (is_utf8)
+ k_flags = HVhek_UTF8;
+ if (key != keysave)
+ k_flags |= HVhek_FREEKEY;
+ }
if (!hash)
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
- if (!xhv->xhv_array) entry = Null(HE*);
+ if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
else
#endif
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (; entry; entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != klen)
continue;
- if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
continue;
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
+ /* If we find the key, but the value is a placeholder, return false. */
+ if (HeVAL(entry) == &PL_sv_undef)
+ return FALSE;
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
- if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
+ if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
(void)hv_store_ent(hv,keysv,sv,hash);
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
return TRUE;
}
}
#endif
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
return FALSE;
}
S_hsplit(pTHX_ HV *hv)
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
- I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
+ I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
register I32 newsize = oldsize * 2;
register I32 i;
- register char *a = xhv->xhv_array;
+ register char *a = xhv->xhv_array; /* HvARRAY(hv) */
register HE **aep;
register HE **bep;
register HE *entry;
return;
}
#else
-#define MALLOC_OVERHEAD 16
New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
return;
}
- Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
+ Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
- offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
+ offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
- Safefree(xhv->xhv_array);
+ Safefree(xhv->xhv_array /* HvARRAY(hv) */);
#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
- xhv->xhv_max = --newsize;
- xhv->xhv_array = a;
+ xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
+ xhv->xhv_array = a; /* HvARRAY(hv) = a */
aep = (HE**)a;
for (i=0; i<oldsize; i++,aep++) {
*oentry = HeNEXT(entry);
HeNEXT(entry) = *bep;
if (!*bep)
- xhv->xhv_fill++;
+ xhv->xhv_fill++; /* HvFILL(hv)++ */
*bep = entry;
continue;
}
oentry = &HeNEXT(entry);
}
if (!*aep) /* everything moved */
- xhv->xhv_fill--;
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
}
}
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
- I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
+ I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
register I32 newsize;
register I32 i;
register I32 j;
if (newsize < newmax)
return; /* overflow detection */
- a = xhv->xhv_array;
+ a = xhv->xhv_array; /* HvARRAY(hv) */
if (a) {
PL_nomemok = TRUE;
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
- if (!a) {
+ if (!a) {
PL_nomemok = FALSE;
return;
}
#else
New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
- if (!a) {
+ if (!a) {
PL_nomemok = FALSE;
return;
}
- Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
+ Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
if (oldsize >= 64) {
- offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
+ offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
}
else
- Safefree(xhv->xhv_array);
+ Safefree(xhv->xhv_array /* HvARRAY(hv) */);
#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
else {
Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
}
- xhv->xhv_max = --newsize;
- xhv->xhv_array = a;
- if (!xhv->xhv_fill) /* skip rest if no entries */
+ xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
+ xhv->xhv_array = a; /* HvARRAY(hv) = a */
+ if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
return;
aep = (HE**)a;
j -= i;
*oentry = HeNEXT(entry);
if (!(HeNEXT(entry) = aep[j]))
- xhv->xhv_fill++;
+ xhv->xhv_fill++; /* HvFILL(hv)++ */
aep[j] = entry;
continue;
}
oentry = &HeNEXT(entry);
}
if (!*aep) /* everything moved */
- xhv->xhv_fill--;
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
}
}
xhv = (XPVHV*)SvANY(hv);
SvPOK_off(hv);
SvNOK_off(hv);
-#ifndef NODEFAULT_SHAREKEYS
+#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
- xhv->xhv_max = 7; /* start with 8 buckets */
- xhv->xhv_fill = 0;
- xhv->xhv_pmroot = 0;
+#endif
+ xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
+ xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
+ xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
(void)hv_iterinit(hv); /* so each() will start off right */
return hv;
}
HV *
Perl_newHVhv(pTHX_ HV *ohv)
{
- register HV *hv;
- STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
- STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
-
- hv = newHV();
- while (hv_max && hv_max + 1 >= hv_fill * 2)
- hv_max = hv_max / 2; /* Is always 2^n-1 */
- HvMAX(hv) = hv_max;
- if (!hv_fill)
+ HV *hv = newHV();
+ STRLEN hv_max, hv_fill;
+
+ if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
return hv;
+ hv_max = HvMAX(ohv);
+
+ if (!SvMAGICAL((SV *)ohv)) {
+ /* It's an ordinary hash, so copy it fast. AMS 20010804 */
+ int i, shared = !!HvSHAREKEYS(ohv);
+ HE **ents, **oents = (HE **)HvARRAY(ohv);
+ char *a;
+ New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
+ ents = (HE**)a;
+
+ /* In each bucket... */
+ for (i = 0; i <= hv_max; i++) {
+ HE *prev = NULL, *ent = NULL, *oent = oents[i];
+
+ if (!oent) {
+ ents[i] = NULL;
+ continue;
+ }
-#if 0
- if (! SvTIED_mg((SV*)ohv, 'P')) {
- /* Quick way ???*/
- }
- else
-#endif
- {
+ /* Copy the linked list of entries. */
+ for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
+ U32 hash = HeHASH(oent);
+ char *key = HeKEY(oent);
+ STRLEN len = HeKLEN(oent);
+ int flags = HeKFLAGS(oent);
+
+ ent = new_HE();
+ HeVAL(ent) = newSVsv(HeVAL(oent));
+ HeKEY_hek(ent)
+ = shared ? share_hek_flags(key, len, hash, flags)
+ : save_hek_flags(key, len, hash, flags);
+ if (prev)
+ HeNEXT(prev) = ent;
+ else
+ ents[i] = ent;
+ prev = ent;
+ HeNEXT(ent) = NULL;
+ }
+ }
+
+ HvMAX(hv) = hv_max;
+ HvFILL(hv) = hv_fill;
+ HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
+ HvARRAY(hv) = ents;
+ }
+ else {
+ /* Iterate over ohv, copying keys and values one at a time. */
HE *entry;
- I32 hv_riter = HvRITER(ohv); /* current root of iterator */
- HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
-
- /* Slow way */
+ I32 riter = HvRITER(ohv);
+ HE *eiter = HvEITER(ohv);
+
+ /* Can we use fewer buckets? (hv_max is always 2^n-1) */
+ while (hv_max && hv_max + 1 >= hv_fill * 2)
+ hv_max = hv_max / 2;
+ HvMAX(hv) = hv_max;
+
hv_iterinit(ohv);
- while (entry = hv_iternext(ohv)) {
- hv_store(hv, HeKEY(entry), HeKLEN(entry),
- SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
+ while ((entry = hv_iternext_flags(ohv, 0))) {
+ hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
+ newSVsv(HeVAL(entry)), HeHASH(entry),
+ HeKFLAGS(entry));
}
- HvRITER(ohv) = hv_riter;
- HvEITER(ohv) = hv_eiter;
+ HvRITER(ohv) = riter;
+ HvEITER(ohv) = eiter;
}
-
+
return hv;
}
SvREFCNT_dec(val);
if (HeKLEN(entry) == HEf_SVKEY) {
SvREFCNT_dec(HeKEY_sv(entry));
- Safefree(HeKEY_hek(entry));
+ Safefree(HeKEY_hek(entry));
}
else if (HvSHAREKEYS(hv))
unshare_hek(HeKEY_hek(entry));
register XPVHV* xhv;
if (!hv)
return;
+
+ if(SvREADONLY(hv)) {
+ Perl_croak(aTHX_ "Attempt to clear a restricted hash");
+ }
+
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
- xhv->xhv_fill = 0;
- xhv->xhv_keys = 0;
- if (xhv->xhv_array)
- (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
+ xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
+ xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
+ xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
+ if (xhv->xhv_array /* HvARRAY(hv) */)
+ (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
+ (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
if (SvRMAGICAL(hv))
- mg_clear((SV*)hv);
+ mg_clear((SV*)hv);
+
+ HvHASKFLAGS_off(hv);
}
STATIC void
if (++riter > max)
break;
entry = array[riter];
- }
+ }
}
(void)hv_iterinit(hv);
}
return;
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
- Safefree(xhv->xhv_array);
+ Safefree(xhv->xhv_array /* HvARRAY(hv) */);
if (HvNAME(hv)) {
Safefree(HvNAME(hv));
HvNAME(hv) = 0;
}
- xhv->xhv_array = 0;
- xhv->xhv_max = 7; /* it's a normal hash */
- xhv->xhv_fill = 0;
- xhv->xhv_keys = 0;
+ xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
+ xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
+ xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
+ xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
+ xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
if (SvRMAGICAL(hv))
- mg_clear((SV*)hv);
+ mg_clear((SV*)hv);
}
/*
Prepares a starting point to traverse a hash table. Returns the number of
keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
-currently only meaningful for hashes without tie magic.
+currently only meaningful for hashes without tie magic.
NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
hash buckets that happen to be in use. If you still need that esoteric
value, you can get it through the macro C<HvFILL(tb)>.
+
=cut
*/
if (!hv)
Perl_croak(aTHX_ "Bad hash");
xhv = (XPVHV*)SvANY(hv);
- entry = xhv->xhv_eiter;
+ entry = xhv->xhv_eiter; /* HvEITER(hv) */
if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
hv_free_ent(hv, entry);
}
- xhv->xhv_riter = -1;
- xhv->xhv_eiter = Null(HE*);
- return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
+ xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
+ xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
+ /* used to be xhv->xhv_fill before 5.004_65 */
+ return XHvTOTALKEYS(xhv);
}
-
/*
=for apidoc hv_iternext
HE *
Perl_hv_iternext(pTHX_ HV *hv)
{
+ return hv_iternext_flags(hv, 0);
+}
+
+/*
+XXX=for apidoc hv_iternext
+
+Returns entries from a hash iterator. See C<hv_iterinit>.
+
+XXX=cut
+*/
+
+HE *
+Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
+{
register XPVHV* xhv;
register HE *entry;
HE *oldentry;
if (!hv)
Perl_croak(aTHX_ "Bad hash");
xhv = (XPVHV*)SvANY(hv);
- oldentry = entry = xhv->xhv_eiter;
+ oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
- if (mg = SvTIED_mg((SV*)hv, 'P')) {
+ if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
SV *key = sv_newmortal();
if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
char *k;
HEK *hek;
- xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
+ /* one HE per MAGICAL hash */
+ xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
Zero(entry, 1, HE);
Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
hek = (HEK*)k;
HeKLEN(entry) = HEf_SVKEY;
}
magic_nextpack((SV*) hv,mg,key);
- if (SvOK(key)) {
+ if (SvOK(key)) {
/* force key to stay around until next time */
HeSVKEY_set(entry, SvREFCNT_inc(key));
return entry; /* beware, hent_val is not set */
- }
+ }
if (HeVAL(entry))
SvREFCNT_dec(HeVAL(entry));
Safefree(HeKEY_hek(entry));
del_HE(entry);
- xhv->xhv_eiter = Null(HE*);
+ xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
return Null(HE*);
}
#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
- if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
+ if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
prime_env_iter();
#endif
- if (!xhv->xhv_array)
- Newz(506, xhv->xhv_array,
- PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ if (!xhv->xhv_array /* !HvARRAY(hv) */)
+ Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
+ PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
+ char);
if (entry)
+ {
entry = HeNEXT(entry);
+ if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
+ /*
+ * Skip past any placeholders -- don't want to include them in
+ * any iteration.
+ */
+ while (entry && HeVAL(entry) == &PL_sv_undef) {
+ entry = HeNEXT(entry);
+ }
+ }
+ }
while (!entry) {
- ++xhv->xhv_riter;
- if (xhv->xhv_riter > xhv->xhv_max) {
- xhv->xhv_riter = -1;
+ xhv->xhv_riter++; /* HvRITER(hv)++ */
+ if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
+ xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
break;
}
+ /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
+
+ if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
+ /* if we have an entry, but it's a placeholder, don't count it */
+ if (entry && HeVAL(entry) == &PL_sv_undef)
+ entry = 0;
+ }
}
if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
hv_free_ent(hv, oldentry);
}
- xhv->xhv_eiter = entry;
+ xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
}
SV *
Perl_hv_iterkeysv(pTHX_ register HE *entry)
{
- if (HeKLEN(entry) == HEf_SVKEY)
- return sv_mortalcopy(HeKEY_sv(entry));
- else
- return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
- HeKLEN(entry)));
+ if (HeKLEN(entry) != HEf_SVKEY) {
+ HEK *hek = HeKEY_hek(entry);
+ int flags = HEK_FLAGS(hek);
+ SV *sv;
+
+ if (flags & HVhek_WASUTF8) {
+ /* Trouble :-)
+ Andreas would like keys he put in as utf8 to come back as utf8
+ */
+ STRLEN utf8_len = HEK_LEN(hek);
+ U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+
+ sv = newSVpvn ((char*)as_utf8, utf8_len);
+ SvUTF8_on (sv);
+ } else {
+ sv = newSVpvn_share(HEK_KEY(hek),
+ (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
+ HEK_HASH(hek));
+ }
+ return sv_2mortal(sv);
+ }
+ return sv_mortalcopy(HeKEY_sv(entry));
}
/*
Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
{
if (SvRMAGICAL(hv)) {
- if (mg_find((SV*)hv,'P')) {
+ if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
SV* sv = sv_newmortal();
if (HeKLEN(entry) == HEf_SVKEY)
mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
{
HE *he;
- if ( (he = hv_iternext(hv)) == NULL)
+ if ( (he = hv_iternext_flags(hv, 0)) == NULL)
return NULL;
*key = hv_iterkey(he, retlen);
return hv_iterval(hv, he);
sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
}
+#if 0 /* use the macro from hv.h instead */
+
char*
Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
{
return HEK_KEY(share_hek(sv, len, hash));
}
+#endif
+
/* possibly free a shared string if no one has access to it
* len and hash must both be valid for str.
*/
void
Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
{
+ unshare_hek_or_pvn (NULL, str, len, hash);
+}
+
+
+void
+Perl_unshare_hek(pTHX_ HEK *hek)
+{
+ unshare_hek_or_pvn(hek, NULL, 0, 0);
+}
+
+/* possibly free a shared string if no one has access to it
+ hek if non-NULL takes priority over the other 3, else str, len and hash
+ are used. If so, len and hash must both be valid for str.
+ */
+void
+S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
+{
register XPVHV* xhv;
register HE *entry;
register HE **oentry;
register I32 i = 1;
I32 found = 0;
-
+ bool is_utf8 = FALSE;
+ int k_flags = 0;
+ const char *save = str;
+
+ if (hek) {
+ hash = HEK_HASH(hek);
+ } else if (len < 0) {
+ STRLEN tmplen = -len;
+ is_utf8 = TRUE;
+ /* See the note in hv_fetch(). --jhi */
+ str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
+ len = tmplen;
+ if (is_utf8)
+ k_flags = HVhek_UTF8;
+ if (str != save)
+ k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
+
/* what follows is the moral equivalent of:
if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
if (--*Svp == Nullsv)
xhv = (XPVHV*)SvANY(PL_strtab);
/* assert(xhv_array != 0) */
LOCK_STRTAB_MUTEX;
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
- if (HeHASH(entry) != hash) /* strings can't be equal */
- continue;
- if (HeKLEN(entry) != len)
- continue;
- if (memNE(HeKEY(entry),str,len)) /* is this it? */
- continue;
- found = 1;
- if (--HeVAL(entry) == Nullsv) {
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--;
- Safefree(HeKEY_hek(entry));
- del_HE(entry);
- --xhv->xhv_keys;
- }
- break;
+ if (hek) {
+ for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeKEY_hek(entry) != hek)
+ continue;
+ found = 1;
+ break;
+ }
+ } else {
+ int flags_masked = k_flags & HVhek_MASK;
+ for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != len)
+ continue;
+ if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
+ continue;
+ if (HeKFLAGS(entry) != flags_masked)
+ continue;
+ found = 1;
+ break;
+ }
}
- UNLOCK_STRTAB_MUTEX;
-
- {
- dTHR;
- if (!found && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");
+
+ if (found) {
+ if (--HeVAL(entry) == Nullsv) {
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--; /* HvFILL(hv)-- */
+ Safefree(HeKEY_hek(entry));
+ del_HE(entry);
+ xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ }
}
+
+ UNLOCK_STRTAB_MUTEX;
+ if (!found && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free non-existent shared string '%s'%s",
+ hek ? HEK_KEY(hek) : str,
+ (k_flags & HVhek_UTF8) ? " (utf8)" : "");
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(str);
}
/* get a (constant) string ptr from the global string table
HEK *
Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
{
+ bool is_utf8 = FALSE;
+ int flags = 0;
+ const char *save = str;
+
+ if (len < 0) {
+ STRLEN tmplen = -len;
+ is_utf8 = TRUE;
+ /* See the note in hv_fetch(). --jhi */
+ str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
+ len = tmplen;
+ /* If we were able to downgrade here, then than means that we were passed
+ in a key which only had chars 0-255, but was utf8 encoded. */
+ if (is_utf8)
+ flags = HVhek_UTF8;
+ /* If we found we were able to downgrade the string to bytes, then
+ we should flag that it needs upgrading on keys or each. Also flag
+ that we need share_hek_flags to free the string. */
+ if (str != save)
+ flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
+
+ return share_hek_flags (str, len, hash, flags);
+}
+
+HEK *
+S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
+{
register XPVHV* xhv;
register HE *entry;
register HE **oentry;
register I32 i = 1;
I32 found = 0;
+ int flags_masked = flags & HVhek_MASK;
/* what follows is the moral equivalent of:
-
+
if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
- hv_store(PL_strtab, str, len, Nullsv, hash);
+ hv_store(PL_strtab, str, len, Nullsv, hash);
*/
xhv = (XPVHV*)SvANY(PL_strtab);
/* assert(xhv_array != 0) */
LOCK_STRTAB_MUTEX;
+ /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != len)
continue;
- if (memNE(HeKEY(entry),str,len)) /* is this it? */
+ if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
+ continue;
+ if (HeKFLAGS(entry) != flags_masked)
continue;
found = 1;
break;
}
if (!found) {
entry = new_HE();
- HeKEY_hek(entry) = save_hek(str, len, hash);
+ HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
*oentry = entry;
- xhv->xhv_keys++;
+ xhv->xhv_keys++; /* HvKEYS(hv)++ */
if (i) { /* initial entry? */
- ++xhv->xhv_fill;
- if (xhv->xhv_keys > xhv->xhv_max)
+ xhv->xhv_fill++; /* HvFILL(hv)++ */
+ if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
hsplit(PL_strtab);
}
}
++HeVAL(entry); /* use value slot as REFCNT */
UNLOCK_STRTAB_MUTEX;
- return HeKEY_hek(entry);
-}
-
+ if (flags & HVhek_FREEKEY)
+ Safefree(str);
+ return HeKEY_hek(entry);
+}