X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=2d04dda6ac5a126302c69179b051ad1e60d67ea4;hb=142630c421426ba21e7cdcbb5134d1beb565440f;hp=78b1f9de2a7648f7792043417a4629939eaca226;hpb=4e2344ada78d8742c0023d545c1baed6597bae39;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index 78b1f9d..2d04dda 100644 --- a/hv.c +++ b/hv.c @@ -1,7 +1,7 @@ /* 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. @@ -14,6 +14,16 @@ /* =head1 Hash Manipulation Functions + +A HV structure represents a Perl hash. It consists mainly of an array +of pointers, each of which points to a linked list of HE structures. The +array is indexed by the hash function of the key, so each linked list +represents all the hash entries with the same hash value. Each HE contains +a pointer to the actual value, plus a pointer to a HEK structure which +holds the key and hash value. + +=cut + */ #include "EXTERN.h" @@ -80,6 +90,7 @@ S_more_he(pTHX) 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; @@ -89,7 +100,10 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) 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; } @@ -214,7 +228,7 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) flags = 0; } hek = hv_fetch_common (hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0); + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); return hek ? &HeVAL(hek) : NULL; } @@ -365,7 +379,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) (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) { @@ -381,6 +395,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return 0; if (keysv) { + if (flags & HVhek_FREEKEY) + Safefree(key); key = SvPV(keysv, klen); flags = 0; is_utf8 = (SvUTF8(keysv) != 0); @@ -437,25 +453,28 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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 @@ -496,6 +515,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, key = (const char*)strupr((char*)key); is_utf8 = 0; hash = 0; + keysv = 0; if (flags & HVhek_FREEKEY) { Safefree(keysave); @@ -538,6 +558,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, key = (const char*)strupr((char*)key); is_utf8 = 0; hash = 0; + keysv = 0; if (flags & HVhek_FREEKEY) { Safefree(keysave); @@ -857,7 +878,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) 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) { @@ -873,6 +894,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return Nullsv; if (keysv) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); key = SvPV(keysv, klen); k_flags = 0; is_utf8 = (SvUTF8(keysv) != 0); @@ -902,25 +925,20 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } 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); @@ -954,7 +972,6 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } else { PERL_HASH(hash, key, klen); } - PERL_HASH(hash, key, klen); } masked_flags = (k_flags & HVhek_MASK); @@ -972,34 +989,21 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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; @@ -1015,6 +1019,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, * 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 */ @@ -1059,6 +1064,17 @@ S_hsplit(pTHX_ HV *hv) 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); @@ -1480,7 +1496,7 @@ Clears any placeholders from a hash. If a restricted hash has any of its keys marked as readonly and the key is subsequently deleted, the key is not actually deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags it so it will be ignored by future operations such as iterating over the hash, -but will still allow the hash to have a value reaasigned to the key at some +but will still allow the hash to have a value reassigned to the key at some future point. This function clears any such placeholder keys from the hash. See Hash::Util::lock_keys() for an example of its use. @@ -1490,42 +1506,48 @@ See Hash::Util::lock_keys() for an example of its use. 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 @@ -2006,9 +2028,10 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) 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); } @@ -2081,7 +2104,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) } 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;