/* hv.c
*
- * Copyright (c) 1991-2001, 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;
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;
}
is_utf8 = TRUE;
}
- 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_LEN(hek) = len;
HEK_HASH(hek) = hash;
HEK_UTF8(hek) = (char)is_utf8;
#if defined(USE_ITHREADS)
HE *
-Perl_he_dup(pTHX_ HE *e, bool shared, clone_params* param)
+Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
{
HE *ret;
}
#endif /* USE_ITHREADS */
+static void
+Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
+ const char *keysave, const char *msg)
+{
+ SV *sv = sv_newmortal();
+ if (key == keysave) {
+ 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 (is_utf8) {
+ SvUTF8_on(sv);
+ }
+ Perl_croak(aTHX_ msg, 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.
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 */
- || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
+ || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
#endif
- )
+ )
Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
char);
continue;
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 &HeVAL(entry);
+
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
}
}
#endif
+ if (!entry && SvREADONLY(hv)) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' in a fixed hash"
+ );
+ }
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
if (key != keysave) { /* must be is_utf8 == 0 */
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
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 */
- || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
+ || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
#endif
- )
+ )
Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
char);
continue;
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 */
}
}
#endif
+ if (!entry && SvREADONLY(hv)) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' in a fixed hash"
+ );
+ }
if (key != keysave)
Safefree(key);
if (lval) { /* gonna assign to this, so it better be there */
return 0;
#ifdef ENV_IS_CASELESS
else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- key = savepvn(key,klen);
+ key = savepvn(key,klen);
key = (const char*)strupr((char*)key);
hash = 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;
+ HvUTF8KEYS_on((SV*)hv);
}
if (!hash)
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
- SvREFCNT_dec(HeVAL(entry));
+ if (HeVAL(entry) == &PL_sv_undef)
+ xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
+ else
+ SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
if (key != keysave)
Safefree(key);
return &HeVAL(entry);
}
+ if (SvREADONLY(hv)) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' to a fixed hash"
+ );
+ }
+
entry = new_HE();
if (HvSHAREKEYS(hv))
HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
- 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;
+ 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, PERL_MAGIC_env)) {
key = SvPV(keysv, klen);
keysave = key = SvPV(keysv, klen);
is_utf8 = (SvUTF8(keysv) != 0);
- if (is_utf8)
+ if (is_utf8) {
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+ HvUTF8KEYS_on((SV*)hv);
+ }
if (!hash)
PERL_HASH(hash, key, klen);
continue;
if (HeKUTF8(entry) != (char)is_utf8)
continue;
- SvREFCNT_dec(HeVAL(entry));
+ if (HeVAL(entry) == &PL_sv_undef)
+ xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
+ else
+ SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
if (key != keysave)
Safefree(key);
return entry;
}
+ if (SvREADONLY(hv)) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' to a fixed hash"
+ );
+ }
+
entry = new_HE();
if (HvSHAREKEYS(hv))
HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
key = strupr(SvPVX(sv));
}
#endif
- }
+ }
}
xhv = (XPVHV*)SvANY(hv);
if (!xhv->xhv_array /* !HvARRAY(hv) */)
continue;
if (key != keysave)
Safefree(key);
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--; /* HvFILL(hv)-- */
+ /* 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)
+ HvUTF8KEYS_off(hv);
+ xhv->xhv_placeholders--;
+ return Nullsv;
+ }
+ }
+ else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to delete readonly key '%"SVf"' from a fixed hash"
+ );
+ }
+
if (flags & G_DISCARD)
sv = Nullsv;
else {
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
+
+ /*
+ * 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)
+ HvUTF8KEYS_off(hv);
+ }
return sv;
}
+ if (SvREADONLY(hv)) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' from a fixed hash"
+ );
+ }
+
if (key != keysave)
Safefree(key);
return Nullsv;
continue;
if (key != keysave)
Safefree(key);
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--; /* HvFILL(hv)-- */
+
+ /* 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)
+ HvUTF8KEYS_off(hv);
+ xhv->xhv_placeholders--;
+ return Nullsv;
+ }
+ else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to delete readonly key '%"SVf"' from a fixed hash"
+ );
+ }
+
if (flags & G_DISCARD)
sv = Nullsv;
else {
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_undef;
}
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
+
+ /*
+ * 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)
+ HvUTF8KEYS_off(hv);
+ }
return sv;
}
+ if (SvREADONLY(hv)) {
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to delete disallowed key '%"SVf"' from a fixed hash"
+ );
+ }
+
if (key != keysave)
Safefree(key);
return Nullsv;
continue;
if (key != keysave)
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 (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
- SV* svret = sv_newmortal();
+ SV* svret = sv_newmortal();
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
- magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
- return SvTRUE(svret);
+ magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
+ return SvTRUE(svret);
}
#ifdef ENV_IS_CASELESS
else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
continue;
if (key != keysave)
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? */
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;
}
/* It's an ordinary hash, so copy it fast. AMS 20010804 */
int i, shared = !!HvSHAREKEYS(ohv);
HE **ents, **oents = (HE **)HvARRAY(ohv);
- New(0, (char *)ents, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
+ 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++) {
HvMAX(hv) = hv_max;
HvFILL(hv) = hv_fill;
- HvKEYS(hv) = HvKEYS(ohv);
+ HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
HvARRAY(hv) = ents;
}
else {
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 fixed hash");
+ }
+
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
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);
+
+ HvUTF8KEYS_off(hv);
}
STATIC void
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);
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 xhv->xhv_keys; /* HvKEYS(hv) */
+ return XHvTOTALKEYS(xhv);
}
/*
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));
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
char);
if (entry)
+ {
entry = HeNEXT(entry);
+ /*
+ * 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++; /* HvRITER(hv)++ */
if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
}
/* entry = (HvARRAY(hv))[HvRITER(hv)]; */
entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
+
+ /* 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? */
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.
*/
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);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent shared string '%s'",str);
}
/* get a (constant) string ptr from the global string table
/* 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) */
https://perl5.git.perl.org / perl5.git / blobdiff