diff options
Diffstat (limited to 'generic/tclLiteral.c')
| -rw-r--r-- | generic/tclLiteral.c | 285 |
1 files changed, 196 insertions, 89 deletions
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 6a617b0..dc8770d 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -31,7 +31,7 @@ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static unsigned int HashString(const char *bytes, int length); +static unsigned HashString(const char *string, int length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -63,7 +63,7 @@ TclInitLiteralTable( * supplied by the caller. */ { #if (TCL_SMALL_HASH_TABLE != 4) - Tcl_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4", + Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable", TCL_SMALL_HASH_TABLE); #endif @@ -131,7 +131,7 @@ TclDeleteLiteralTable( objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - ckfree((char *) entryPtr); + ckfree(entryPtr); entryPtr = nextPtr; } } @@ -141,7 +141,7 @@ TclDeleteLiteralTable( */ if (tablePtr->buckets != tablePtr->staticBuckets) { - ckfree((char *) tablePtr->buckets); + ckfree(tablePtr->buckets); } } @@ -153,20 +153,20 @@ TclDeleteLiteralTable( * Find, or if necessary create, an object in the interpreter's literal * table that has a string representation matching the argument * string. If nsPtr!=NULL then only literals stored for the namespace are - * considered. + * considered. * * Results: * The literal object. If it was created in this call *newPtr is set to - * 1, else 0. NULL is returned if newPtr==NULL and no literal is found. + * 1, else 0. NULL is returned if newPtr==NULL and no literal is found. * * Side effects: - * Increments the ref count of the global LiteralEntry since the caller - * now holds a reference. - * If LITERAL_ON_HEAP is set in flags, this function is given ownership - * of the string: if an object is created then its string representation - * is set directly from string, otherwise the string is freed. Typically, - * a caller sets LITERAL_ON_HEAP if "string" is an already heap-allocated - * buffer holding the result of backslash substitutions. + * Increments the ref count of the global LiteralEntry since the caller + * now holds a reference. If LITERAL_ON_HEAP is set in flags, this + * function is given ownership of the string: if an object is created + * then its string representation is set directly from string, otherwise + * the string is freed. Typically, a caller sets LITERAL_ON_HEAP if + * "string" is an already heap-allocated buffer holding the result of + * backslash substitutions. * *---------------------------------------------------------------------- */ @@ -174,24 +174,26 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - char *bytes, - int length, - unsigned int hash, /* The string's hash. If -1, it will be computed here */ + char *bytes, /* The start of the string. Note that this is + * not a NUL-terminated string. */ + int length, /* Number of bytes in the string. */ + unsigned hash, /* The string's hash. If -1, it will be + * computed here. */ int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr) { - LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; int globalHash; Tcl_Obj *objPtr; - + /* * Is it in the interpreter's global literal table? */ - if (hash == (unsigned int) -1) { + if (hash == (unsigned) -1) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); @@ -242,12 +244,12 @@ TclCreateLiteral( #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { - Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", - (length>60? 60 : length), bytes); + Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", + "TclRegisterLiteral", (length>60? 60 : length), bytes); } #endif - globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); + globalPtr = ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; globalPtr->refCount = 1; globalPtr->nsPtr = nsPtr; @@ -280,8 +282,8 @@ TclCreateLiteral( } } if (!found) { - Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", - (length>60? 60 : length), bytes); + Tcl_Panic("%s: literal \"%.*s\" wasn't global", + "TclRegisterLiteral", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -303,6 +305,33 @@ TclCreateLiteral( /* *---------------------------------------------------------------------- * + * TclFetchLiteral -- + * + * Fetch from a CompileEnv the literal value identified by an index + * value, as returned by a prior call to TclRegisterLiteral(). + * + * Results: + * The literal value, or NULL if the index is out of range. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclFetchLiteral( + CompileEnv *envPtr, /* Points to the CompileEnv from which to + * fetch the registered literal value. */ + unsigned int index) /* Index of the desired literal, as returned + * by prior call to TclRegisterLiteral() */ +{ + if (index >= (unsigned int) envPtr->literalArrayNext) { + return NULL; + } + return envPtr->literalArrayPtr[index].objPtr; +} + +/* + *---------------------------------------------------------------------- + * * TclRegisterLiteral -- * * Find, or if necessary create, an object in a CompileEnv literal array @@ -329,7 +358,7 @@ TclCreateLiteral( int TclRegisterLiteral( - CompileEnv *envPtr, /* Points to the CompileEnv in whose object + void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ register char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object @@ -339,15 +368,16 @@ TclRegisterLiteral( * first null character. */ int flags) /* If LITERAL_ON_HEAP then the caller already * malloc'd bytes and ownership is passed to - * this function. If LITERAL_NS_SCOPE then - * the literal shouldnot be shared accross + * this function. If LITERAL_CMD_NAME then + * the literal should not be shared accross * namespaces. */ { + CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; - LiteralTable *localTablePtr = &(envPtr->localLitTable); + LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; - unsigned int hash; + unsigned hash; int localHash, objIndex, new; Namespace *nsPtr; @@ -381,30 +411,35 @@ TclRegisterLiteral( } /* - * The literal is new to this CompileEnv. Should it be shared accross - * namespaces? If it is a fully qualified name, the namespace - * specification is not needed to avoid sharing. + * The literal is new to this CompileEnv. If it is a command name, avoid + * sharing it accross namespaces, and try not to share it with non-cmd + * literals. Note that FQ command names can be shared, so that we register + * the namespace as the interp's global NS. */ - if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr - && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) { - nsPtr = iPtr->varFramePtr->nsPtr; + if (flags & LITERAL_CMD_NAME) { + if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) { + nsPtr = iPtr->globalNsPtr; + } else { + nsPtr = iPtr->varFramePtr->nsPtr; + } } else { nsPtr = NULL; } - + /* * Is it in the interpreter's global literal table? If not, create it. */ - objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, - flags, &globalPtr); + objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags, + &globalPtr); objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); #ifdef TCL_COMPILE_DEBUG if (globalPtr->refCount < 1) { - Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, globalPtr->refCount); + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", + "TclRegisterLiteral", (length>60? 60 : length), bytes, + globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ @@ -438,9 +473,9 @@ LookupLiteralEntry( * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *entryPtr; - char *bytes; + const char *bytes; int length, globalHash; bytes = TclGetStringFromObj(objPtr, &length); @@ -485,12 +520,12 @@ TclHideLiteral( * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; - LiteralTable *localTablePtr = &(envPtr->localLitTable); + LiteralTable *localTablePtr = &envPtr->localLitTable; int localHash, length; - char *bytes; + const char *bytes; Tcl_Obj *newObjPtr; - lPtr = &(envPtr->literalArrayPtr[index]); + lPtr = &envPtr->literalArrayPtr[index]; /* * To avoid unwanted sharing we need to copy the object and remove it from @@ -558,7 +593,7 @@ TclAddLiteralObj( objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; - lPtr = &(envPtr->literalArrayPtr[objIndex]); + lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); lPtr->refCount = -1; /* i.e., unused */ @@ -584,7 +619,7 @@ TclAddLiteralObj( * * Side effects: * Expands the literal array if necessary. May rebuild the hash bucket - * array of the CompileEnv's literal array if it becomes too large. + * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ @@ -593,10 +628,10 @@ static int AddLocalLiteralEntry( register CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ - Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ + Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ int localHash) /* Hash value for the literal's string. */ { - register LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; int objIndex; @@ -637,8 +672,8 @@ AddLocalLiteralEntry( if (!found) { bytes = Tcl_GetStringFromObj(objPtr, &length); - Tcl_Panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", - (length>60? 60 : length), bytes); + Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", + "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -676,7 +711,7 @@ ExpandLocalLiteralArray( * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ - LiteralTable *localTablePtr = &(envPtr->localLitTable); + LiteralTable *localTablePtr = &envPtr->localLitTable; int currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; @@ -690,14 +725,14 @@ ExpandLocalLiteralArray( } if (envPtr->mallocedLiteralArray) { - newArrayPtr = (LiteralEntry *) ckrealloc( - (char *)currArrayPtr, newSize); + newArrayPtr = ckrealloc(currArrayPtr, newSize); } else { /* * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves + * code a ckrealloc equivalent for ourselves. */ - newArrayPtr = (LiteralEntry *) ckalloc(newSize); + + newArrayPtr = ckalloc(newSize); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } @@ -709,7 +744,7 @@ ExpandLocalLiteralArray( if (currArrayPtr != newArrayPtr) { for (i=0 ; i<currElems ; i++) { if (newArrayPtr[i].nextPtr != NULL) { - newArrayPtr[i].nextPtr = newArrayPtr + newArrayPtr[i].nextPtr = newArrayPtr + (newArrayPtr[i].nextPtr - currArrayPtr); } } @@ -755,11 +790,16 @@ TclReleaseLiteral( * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; - char *bytes; + const char *bytes; int length, index; + if (iPtr == NULL) { + goto done; + } + + globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); @@ -786,7 +826,7 @@ TclReleaseLiteral( } else { prevPtr->nextPtr = entryPtr->nextPtr; } - ckfree((char *) entryPtr); + ckfree(entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); @@ -803,6 +843,7 @@ TclReleaseLiteral( * Remove the reference corresponding to the local literal table entry. */ + done: Tcl_DecrRefCount(objPtr); } @@ -823,13 +864,12 @@ TclReleaseLiteral( *---------------------------------------------------------------------- */ -static unsigned int +static unsigned HashString( - register const char *bytes, /* String for which to compute hash value. */ + register const char *string, /* String for which to compute hash value. */ int length) /* Number of bytes in the string. */ { - register unsigned int result; - register int i; + register unsigned int result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -839,17 +879,33 @@ HashString( * following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and - * multiplying by 9 is just about as good. + * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the hash value - * for ever, plus they spread fairly rapidly up to the high-order bits - * to fill out the hash value. This seems works well both for decimal - * and non-decimal strings. + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings. + * + * Note that this function is very weak against malicious strings; it's + * very easy to generate multiple keys that have the same hashcode. On the + * other hand, that hardly ever actually occurs and this function *is* + * very cheap, even by comparison with industry-standard hashes like FNV. + * If real strength of hash is required though, use a custom hash based on + * Bob Jenkins's lookup3(), but be aware that it's significantly slower. + * Tcl scripts tend to not have a big issue in this area, and literals + * mostly aren't looked up by name anyway. + * + * See also HashStringKey in tclHash.c. + * See also TclObjHashKey in tclObj.c. + * + * See [tcl-Feature Request #2958832] */ - result = 0; - for (i=0 ; i<length ; i++) { - result += (result<<3) + bytes[i]; + if (length > 0) { + result = UCHAR(*string); + while (--length) { + result += (result << 3) + UCHAR(*++string); + } } return result; } @@ -881,7 +937,7 @@ RebuildLiteralTable( register LiteralEntry **oldChainPtr, **newChainPtr; register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; - char *bytes; + const char *bytes; int oldSize, count, index, length; oldSize = tablePtr->numBuckets; @@ -903,8 +959,7 @@ RebuildLiteralTable( } tablePtr->numBuckets *= 4; - tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) - (tablePtr->numBuckets * sizeof(LiteralEntry *))); + tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; @@ -922,7 +977,7 @@ RebuildLiteralTable( index = (HashString(bytes, length) & tablePtr->mask); *oldChainPtr = entryPtr->nextPtr; - bucketPtr = &(tablePtr->buckets[index]); + bucketPtr = &tablePtr->buckets[index]; entryPtr->nextPtr = *bucketPtr; *bucketPtr = entryPtr; } @@ -933,7 +988,52 @@ RebuildLiteralTable( */ if (oldBuckets != tablePtr->staticBuckets) { - ckfree((char *) oldBuckets); + ckfree(oldBuckets); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInvalidateCmdLiteral -- + * + * Invalidate a command literal entry, if present in the literal hash + * tables, by resetting its internal representation. This invalidation + * leaves it in the literal tables and in existing literal arrays. As a + * result, existing references continue to work but we force a fresh + * command look-up upon the next use (see, in particular, + * TclSetCmdNameObj()). + * + * Results: + * None. + * + * Side effects: + * Resets the internal representation of the CmdName Tcl_Obj + * using TclFreeIntRep(). + * + *---------------------------------------------------------------------- + */ + +void +TclInvalidateCmdLiteral( + Tcl_Interp *interp, /* Interpreter for which to invalidate a + * command literal. */ + const char *name, /* Points to the start of the cmd literal + * name. */ + Namespace *nsPtr) /* The namespace for which to lookup and + * invalidate a cmd literal. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + strlen(name), -1, NULL, nsPtr, 0, NULL); + + if (literalObjPtr != NULL) { + if (literalObjPtr->typePtr == &tclCmdNameType) { + TclFreeIntRep(literalObjPtr); + } + /* Balance the refcount effects of TclCreateLiteral() above */ + Tcl_IncrRefCount(literalObjPtr); + TclReleaseLiteral(interp, literalObjPtr); } } @@ -995,7 +1095,7 @@ TclLiteralStats( * Print out the histogram and a few other pieces of information. */ - result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + result = ckalloc(NUM_COUNTERS*60 + 300); sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); @@ -1034,7 +1134,7 @@ TclVerifyLocalLiteralTable( CompileEnv *envPtr) /* Points to CompileEnv whose literal table is * to be validated. */ { - register LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralTable *localTablePtr = &envPtr->localLitTable; register LiteralEntry *localPtr; char *bytes; register int i; @@ -1047,23 +1147,27 @@ TclVerifyLocalLiteralTable( count++; if (localPtr->refCount != -1) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", + Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", + "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", + Tcl_Panic("%s: local literal \"%.*s\" is not global", + "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes); } if (localPtr->objPtr->bytes == NULL) { - Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); + Tcl_Panic("%s: literal has NULL string rep", + "TclVerifyLocalLiteralTable"); } } } if (count != localTablePtr->numEntries) { - Tcl_Panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", - count, localTablePtr->numEntries); + Tcl_Panic("%s: local literal table had %d entries, should be %d", + "TclVerifyLocalLiteralTable", count, + localTablePtr->numEntries); } } @@ -1088,7 +1192,7 @@ TclVerifyGlobalLiteralTable( Interp *iPtr) /* Points to interpreter whose global literal * table is to be validated. */ { - register LiteralTable *globalTablePtr = &(iPtr->literalTable); + register LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *globalPtr; char *bytes; register int i; @@ -1101,17 +1205,20 @@ TclVerifyGlobalLiteralTable( count++; if (globalPtr->refCount < 1) { bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", + "TclVerifyGlobalLiteralTable", (length>60? 60 : length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { - Tcl_Panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); + Tcl_Panic("%s: literal has NULL string rep", + "TclVerifyGlobalLiteralTable"); } } } if (count != globalTablePtr->numEntries) { - Tcl_Panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", - count, globalTablePtr->numEntries); + Tcl_Panic("%s: global literal table had %d entries, should be %d", + "TclVerifyGlobalLiteralTable", count, + globalTablePtr->numEntries); } } #endif /*TCL_COMPILE_DEBUG*/ |