/* hv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
STATIC HEK *
S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
+ int flags_masked = flags & HVhek_MASK;
char *k;
register HEK *hek;
HEK_KEY(hek)[len] = 0;
HEK_LEN(hek) = len;
HEK_HASH(hek) = hash;
- HEK_FLAGS(hek) = (unsigned char)flags;
+ HEK_FLAGS(hek) = (unsigned char)flags_masked;
+
+ if (flags & HVhek_FREEKEY)
+ Safefree(str);
return hek;
}
(lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
}
-HE *
+STATIC HE *
S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
int flags, int action, SV *val, register U32 hash)
{
return 0;
if (keysv) {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
key = SvPV(keysv, klen);
flags = 0;
is_utf8 = (SvUTF8(keysv) != 0);
U32 i;
for (i = 0; i < klen; ++i)
if (isLOWER(key[i])) {
- const char *keysave = key;
- /* Will need to free this, so set FREEKEY flag
- on call to hv_fetch_common. */
- key = savepvn(key,klen);
- key = (const char*)strupr((char*)key);
-
- if (flags & HVhek_FREEKEY)
- Safefree(keysave);
-
- /* This isn't strictly the same as the old hv_fetch
- magic, which made a call to hv_fetch, followed
- by a call to hv_store if that failed and lvalue
- was true.
- Which I believe could have been done by simply
- passing the lvalue through to the first hv_fetch.
- So I will do that here. */
- return hv_fetch_common(hv, Nullsv, key, klen,
- HVhek_FREEKEY,
- action, Nullsv, 0);
+ /* Would be nice if we had a routine to do the
+ copy and upercase in a single pass through. */
+ char *nkey = strupr(savepvn(key,klen));
+ /* Note that this fetch is for nkey (the uppercased
+ key) whereas the store is for key (the original) */
+ entry = hv_fetch_common(hv, Nullsv, nkey, klen,
+ HVhek_FREEKEY, /* free nkey */
+ 0 /* non-LVAL fetch */,
+ Nullsv /* no value */,
+ 0 /* compute hash */);
+ if (!entry && (action & HV_FETCH_LVALUE)) {
+ /* This call will free key if necessary.
+ Do it this way to encourage compiler to tail
+ call optimise. */
+ entry = hv_fetch_common(hv, keysv, key, klen,
+ flags, HV_FETCH_ISSTORE,
+ NEWSV(61,0), hash);
+ } else {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+ }
+ return entry;
}
}
#endif
return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
}
-SV *
+STATIC SV *
S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
int k_flags, I32 d_flags, U32 hash)
{
return Nullsv;
if (keysv) {
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
key = SvPV(keysv, klen);
k_flags = 0;
is_utf8 = (SvUTF8(keysv) != 0);
}
return Nullsv; /* element cannot be deleted */
}
- }
#ifdef ENV_IS_CASELESS
- if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- /* XXX This code isn't UTF8 clean. */
- keysv = sv_2mortal(newSVpvn(key,klen));
- key = strupr(SvPVX(keysv));
-
-#if 0
- /* keysave not in scope - don't understand - NI-S */
- if (k_flags & HVhek_FREEKEY) {
- Safefree(keysave);
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+ /* XXX This code isn't UTF8 clean. */
+ keysv = sv_2mortal(newSVpvn(key,klen));
+ if (k_flags & HVhek_FREEKEY) {
+ Safefree(key);
+ }
+ key = strupr(SvPVX(keysv));
+ is_utf8 = 0;
+ k_flags = 0;
+ hash = 0;
}
#endif
-
- is_utf8 = 0;
- k_flags = 0;
- hash = 0;
}
-#endif
}
}
xhv = (XPVHV*)SvANY(hv);
} else {
PERL_HASH(hash, key, klen);
}
- PERL_HASH(hash, key, klen);
}
masked_flags = (k_flags & HVhek_MASK);
continue;
if ((HeKFLAGS(entry) ^ masked_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_placeholder)
{
- 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;
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
+ 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 (k_flags & HVhek_FREEKEY)
+ Safefree(key);
if (d_flags & G_DISCARD)
sv = Nullsv;
* an error.
*/
if (SvREADONLY(hv)) {
+ SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = &PL_sv_placeholder;
/* We'll be saving this slot, so the number of allocated keys
* doesn't go down, but the number placeholders goes up */
int longest_chain = 0;
int was_shared;
+ /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
+ hv, (int) oldsize);*/
+
+ if (HvPLACEHOLDERS(hv) && !SvREADONLY(hv)) {
+ /* Can make this clear any placeholders first for non-restricted hashes,
+ even though Storable rebuilds restricted hashes by putting in all the
+ placeholders (first) before turning on the readonly flag, because
+ Storable always pre-splits the hash. */
+ hv_clear_placeholders(hv);
+ }
+
PL_nomemok = TRUE;
#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
void
Perl_hv_clear_placeholders(pTHX_ HV *hv)
{
- I32 items;
- items = (I32)HvPLACEHOLDERS(hv);
- if (items) {
- HE *entry;
- I32 riter = HvRITER(hv);
- HE *eiter = HvEITER(hv);
- hv_iterinit(hv);
- /* This may look suboptimal with the items *after* the iternext, but
- it's quite deliberate. We only get here with items==0 if we've
- just deleted the last placeholder in the hash. If we've just done
- that then it means that the hash is in lazy delete mode, and the
- HE is now only referenced in our iterator. If we just quit the loop
- and discarded our iterator then the HE leaks. So we do the && the
- other way to ensure iternext is called just one more time, which
- has the side effect of triggering the lazy delete. */
- while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
- && items) {
- SV *val = hv_iterval(hv, entry);
-
- if (val == &PL_sv_placeholder) {
-
- /* It seems that I have to go back in the front of the hash
- API to delete a hash, even though I have a HE structure
- pointing to the very entry I want to delete, and could hold
- onto the previous HE that points to it. And it's easier to
- go in with SVs as I can then specify the precomputed hash,
- and don't have fun and games with utf8 keys. */
- SV *key = hv_iterkeysv(entry);
-
- hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
- items--;
- }
- }
- HvRITER(hv) = riter;
- HvEITER(hv) = eiter;
- }
+ I32 items = (I32)HvPLACEHOLDERS(hv);
+ I32 i = HvMAX(hv);
+
+ if (items == 0)
+ return;
+
+ do {
+ /* Loop down the linked list heads */
+ int first = 1;
+ HE **oentry = &(HvARRAY(hv))[i];
+ HE *entry = *oentry;
+
+ if (!entry)
+ continue;
+
+ for (; entry; entry = *oentry) {
+ if (HeVAL(entry) == &PL_sv_placeholder) {
+ *oentry = HeNEXT(entry);
+ if (first && !*oentry)
+ HvFILL(hv)--; /* This linked list is now empty. */
+ if (HvEITER(hv))
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+
+ if (--items == 0) {
+ /* Finished. */
+ HvTOTALKEYS(hv) -= HvPLACEHOLDERS(hv);
+ if (HvKEYS(hv) == 0)
+ HvHASKFLAGS_off(hv);
+ HvPLACEHOLDERS(hv) = 0;
+ return;
+ }
+ } else {
+ oentry = &HeNEXT(entry);
+ first = 0;
+ }
+ }
+ } while (--i >= 0);
+ /* You can't get here, hence assertion should always fail. */
+ assert (items == 0);
+ assert (0);
}
STATIC void
UNLOCK_STRTAB_MUTEX;
if (!found && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free non-existent shared string '%s'%s",
+ "Attempt to free non-existent shared string '%s'%s"
+ pTHX__FORMAT,
hek ? HEK_KEY(hek) : str,
- (k_flags & HVhek_UTF8) ? " (utf8)" : "");
+ ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
if (k_flags & HVhek_FREEKEY)
Safefree(str);
}
}
if (!found) {
entry = new_HE();
- HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
+ HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
*oentry = entry;
https://perl5.git.perl.org / perl5.git / blobdiff