/* 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.
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)
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_UTF8(e), HeHASH(e));
+ HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
else
- HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(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;
}
register HE *entry;
SV *sv;
bool is_utf8 = FALSE;
+ const char *keysave = key;
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();
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])) {
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 (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- 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,is_utf8?-klen: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;
}
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)
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 (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- 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;
}
}
register HE *entry;
register HE **oentry;
bool is_utf8 = FALSE;
+ const char *keysave = key;
if (!hv)
return 0;
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 (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- 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();
if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, is_utf8?-klen: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, is_utf8?-klen: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.
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 (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- 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();
if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, is_utf8?-klen: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, is_utf8?-klen: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;
SV **svp;
SV *sv;
bool is_utf8 = FALSE;
+ const char *keysave = key;
if (!hv)
return Nullsv;
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 (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- 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 **oentry;
SV *sv;
bool is_utf8;
+ char *keysave;
if (!hv)
return Nullsv;
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));
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 (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- 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;
SV *sv;
bool is_utf8 = FALSE;
+ const char *keysave = key;
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();
mg_copy((SV*)hv, sv, key, klen);
- magic_existspack(sv, mg_find(sv, 'p'));
+ 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));
}
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 (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- 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);
+ 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));
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 (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;
return hv;
#if 0
- if (! SvTIED_mg((SV*)ohv, 'P')) {
+ if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
/* Quick way ???*/
}
else
/* Slow way */
hv_iterinit(ohv);
while ((entry = hv_iternext(ohv))) {
- hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
- SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
+ hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
+ newSVsv(HeVAL(entry)), HeHASH(entry));
}
HvRITER(ohv) = hv_riter;
HvEITER(ohv) = hv_eiter;
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));
{
if (HeKLEN(entry) == HEf_SVKEY)
return sv_mortalcopy(HeKEY_sv(entry));
- else {
- SV *sv = newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
- HeKLEN(entry), HeHASH(entry));
- if (HeKUTF8(entry))
- SvUTF8_on(sv);
- return sv_2mortal(sv);
- }
+ else
+ 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))) {
continue;
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) {
*oentry = HeNEXT(entry);
break;
}
UNLOCK_STRTAB_MUTEX;
-
- {
- dTHR;
- if (!found && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
- }
+ 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 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:
continue;
if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
continue;
- if (HeKUTF8(entry) != (char)is_utf8)
- continue;
+ if (HeKUTF8(entry) != (char)is_utf8)
+ continue;
found = 1;
break;
}
if (!found) {
entry = new_HE();
- HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
+ 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);
}
-
-
-