/* hv.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, 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.
#define PERL_IN_HV_C
#include "perl.h"
+
STATIC HE*
S_new_he(pTHX)
{
{
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) = 0;
}
+#ifdef PURIFY
+
+#define new_HE() (HE*)safemalloc(sizeof(HE))
+#define del_HE(p) safefree((char*)p)
+
+#else
+
+#define new_HE() new_he()
+#define del_HE(p) del_he(p)
+
+#endif
+
STATIC HEK *
S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
{
char *k;
register HEK *hek;
-
+ bool is_utf8 = FALSE;
+
+ if (len < 0) {
+ len = -len;
+ is_utf8 = TRUE;
+ }
+
New(54, k, HEK_BASESIZE + len + 1, char);
hek = (HEK*)k;
Copy(str, HEK_KEY(hek), len, char);
- *(HEK_KEY(hek) + len) = '\0';
HEK_LEN(hek) = len;
HEK_HASH(hek) = hash;
+ HEK_UTF8(hek) = (char)is_utf8;
return hek;
}
void
Perl_unshare_hek(pTHX_ HEK *hek)
{
- unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
+ unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
+ HEK_HASH(hek));
}
#if defined(USE_ITHREADS)
return ret;
/* create anew and remember what it is */
- ret = new_he();
+ ret = new_HE();
ptr_table_store(PL_ptr_table, e, ret);
HeNEXT(ret) = he_dup(HeNEXT(e),shared);
if (HeKLEN(e) == HEf_SVKEY)
HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
else if (shared)
- HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+ HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
else
- HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+ HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
return ret;
}
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 a 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.
*/
SV**
-Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
+Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
{
register XPVHV* xhv;
register U32 hash;
register HE *entry;
SV *sv;
+ bool is_utf8 = FALSE;
+ const char *keysave = key;
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);
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])) {
xhv = (XPVHV*)SvANY(hv);
if (!xhv->xhv_array) {
- if (lval
+ 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))
#endif
return 0;
}
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+ 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;
+ }
+
PERL_HASH(hash, key, klen);
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
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 (HeKUTF8(entry) != (char)is_utf8)
+ continue;
+ if (key != keysave)
+ Safefree(key);
return &HeVAL(entry);
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
+ if (key != keysave)
+ Safefree(key);
return hv_store(hv,key,klen,sv,hash);
}
}
#endif
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
- return hv_store(hv,key,klen,sv,hash);
+ if (key != keysave) { /* must be is_utf8 == 0 */
+ SV **ret = hv_store(hv,key,klen,sv,hash);
+ Safefree(key);
+ return ret;
+ }
+ else
+ return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
}
+ if (key != keysave)
+ Safefree(key);
return 0;
}
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;
+ 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 (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))
#endif
return 0;
}
- key = SvPV(keysv, klen);
-
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv)!=0);
+
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
if (!hash)
PERL_HASH(hash, key, klen);
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 (HeKUTF8(entry) != (char)is_utf8)
+ continue;
+ if (key != keysave)
+ Safefree(key);
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
}
}
#endif
+ if (key != keysave)
+ 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, register U32 hash)
{
register XPVHV* xhv;
register I32 i;
register HE *entry;
register HE **oentry;
+ bool is_utf8 = FALSE;
+ const char *keysave = key;
if (!hv)
return 0;
+ if (klen < 0) {
+ klen = -klen;
+ is_utf8 = TRUE;
+ }
+
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
bool needs_copy;
if (!xhv->xhv_array && !needs_store)
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 = strupr(key);
hash = 0;
}
#endif
}
}
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = klen;
+ /* See the note in hv_fetch(). --jhi */
+ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
+ klen = tmplen;
+ }
+
if (!hash)
PERL_HASH(hash, key, klen);
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 (HeKUTF8(entry) != (char)is_utf8)
continue;
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
+ if (key != keysave)
+ Safefree(key);
return &HeVAL(entry);
}
- entry = new_he();
+ entry = new_HE();
if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, klen, hash);
+ HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
else /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek(key, klen, hash);
+ HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+ if (key != keysave)
+ Safefree(key);
HeVAL(entry) = val;
HeNEXT(entry) = *oentry;
*oentry = entry;
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.
register I32 i;
register HE *entry;
register HE **oentry;
+ bool is_utf8;
+ 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 (!xhv->xhv_array && !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 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
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 (HeKUTF8(entry) != (char)is_utf8)
continue;
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
+ if (key != keysave)
+ Safefree(key);
return entry;
}
- entry = new_he();
+ entry = new_HE();
if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, klen, hash);
+ HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
else /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek(key, klen, hash);
+ HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+ if (key != keysave)
+ Safefree(key);
HeVAL(entry) = val;
HeNEXT(entry) = *oentry;
*oentry = entry;
=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;
+ 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));
}
if (!xhv->xhv_array)
return Nullsv;
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = klen;
+ /* See the note in hv_fetch(). --jhi */
+ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
+ klen = tmplen;
+ }
+
PERL_HASH(hash, key, klen);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
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 (HeKUTF8(entry) != (char)is_utf8)
+ continue;
+ if (key != keysave)
+ Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
xhv->xhv_fill--;
--xhv->xhv_keys;
return sv;
}
+ if (key != keysave)
+ Safefree(key);
return Nullsv;
}
register HE *entry;
register HE **oentry;
SV *sv;
-
+ bool is_utf8;
+ 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
}
if (!xhv->xhv_array)
return Nullsv;
- key = SvPV(keysv, klen);
-
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
+
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
if (!hash)
PERL_HASH(hash, key, klen);
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 (HeKUTF8(entry) != (char)is_utf8)
+ continue;
+ if (key != keysave)
+ Safefree(key);
*oentry = HeNEXT(entry);
if (i && !*oentry)
xhv->xhv_fill--;
--xhv->xhv_keys;
return sv;
}
+ if (key != keysave)
+ 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;
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;
+ return 0;
#endif
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = klen;
+ /* See the note in hv_fetch(). --jhi */
+ key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
+ klen = tmplen;
+ }
+
PERL_HASH(hash, key, klen);
#ifdef DYNAMIC_ENV_FETCH
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 (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
}
}
#endif
+ if (key != keysave)
+ Safefree(key);
return FALSE;
}
STRLEN klen;
register HE *entry;
SV *sv;
+ bool is_utf8;
+ char *keysave;
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;
+ return 0;
#endif
- key = SvPV(keysv, klen);
+ keysave = key = SvPV(keysv, klen);
+ is_utf8 = (SvUTF8(keysv) != 0);
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+ key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (!hash)
PERL_HASH(hash, key, klen);
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 (HeKUTF8(entry) != (char)is_utf8)
continue;
+ if (key != keysave)
+ Safefree(key);
return TRUE;
}
#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
}
}
#endif
+ if (key != keysave)
+ Safefree(key);
return FALSE;
}
return;
}
#else
-#define MALLOC_OVERHEAD 16
New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
if (!a) {
PL_nomemok = FALSE;
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
+#endif
xhv->xhv_max = 7; /* start with 8 buckets */
xhv->xhv_fill = 0;
xhv->xhv_pmroot = 0;
return hv;
#if 0
- if (! SvTIED_mg((SV*)ohv, 'P')) {
+ if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
/* Quick way ???*/
- }
- else
+ }
+ else
#endif
{
HE *entry;
/* Slow way */
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(ohv))) {
+ hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
+ newSVsv(HeVAL(entry)), HeHASH(entry));
}
HvRITER(ohv) = hv_riter;
HvEITER(ohv) = hv_eiter;
}
-
+
return hv;
}
unshare_hek(HeKEY_hek(entry));
else
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
}
void
unshare_hek(HeKEY_hek(entry));
else
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
}
/*
(void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
if (SvRMAGICAL(hv))
- mg_clear((SV*)hv);
+ mg_clear((SV*)hv);
}
STATIC void
if (++riter > max)
break;
entry = array[riter];
- }
+ }
}
(void)hv_iterinit(hv);
}
xhv->xhv_keys = 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
xhv = (XPVHV*)SvANY(hv);
oldentry = entry = xhv->xhv_eiter;
- 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 */
+ xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
Zero(entry, 1, HE);
Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
hek = (HEK*)k;
if (HeVAL(entry))
SvREFCNT_dec(HeVAL(entry));
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
xhv->xhv_eiter = Null(HE*);
return Null(HE*);
}
if (HeKLEN(entry) == HEf_SVKEY)
return sv_mortalcopy(HeKEY_sv(entry));
else
- return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
- HeKLEN(entry)));
+ return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
+ HeKLEN_UTF8(entry), HeHASH(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);
register HE **oentry;
register I32 i = 1;
I32 found = 0;
-
+ bool is_utf8 = FALSE;
+ const char *save = str;
+
+ if (len < 0) {
+ len = -len;
+ is_utf8 = TRUE;
+ if (!(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = len;
+ /* See the note in hv_fetch(). --jhi */
+ str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
+ len = tmplen;
+ }
+ }
+
/* what follows is the moral equivalent of:
if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
if (--*Svp == Nullsv)
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 (HeKUTF8(entry) != (char)is_utf8)
continue;
found = 1;
if (--HeVAL(entry) == Nullsv) {
if (i && !*oentry)
xhv->xhv_fill--;
Safefree(HeKEY_hek(entry));
- del_he(entry);
+ del_HE(entry);
--xhv->xhv_keys;
}
break;
}
UNLOCK_STRTAB_MUTEX;
-
- {
- dTHR;
- if (!found && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");
- }
+ if (str != save)
+ Safefree(str);
+ if (!found && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
}
/* get a (constant) string ptr from the global string table
register HE **oentry;
register I32 i = 1;
I32 found = 0;
+ bool is_utf8 = FALSE;
+ const char *save = str;
+
+ if (len < 0) {
+ len = -len;
+ is_utf8 = TRUE;
+ if (!(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = len;
+ /* See the note in hv_fetch(). --jhi */
+ str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
+ len = tmplen;
+ }
+ }
/* what follows is the moral equivalent of:
-
+
if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
hv_store(PL_strtab, str, len, Nullsv, hash);
*/
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 (HeKUTF8(entry) != (char)is_utf8)
continue;
found = 1;
break;
}
if (!found) {
- entry = new_he();
- HeKEY_hek(entry) = save_hek(str, len, hash);
+ entry = new_HE();
+ HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
*oentry = entry;
++HeVAL(entry); /* use value slot as REFCNT */
UNLOCK_STRTAB_MUTEX;
+ if (str != save)
+ Safefree(str);
return HeKEY_hek(entry);
}
-
-
-
https://perl5.git.perl.org / perl5.git / blobdiff