summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog19
-rw-r--r--generic/tclCmdIL.c9
-rw-r--r--generic/tclCompile.c10
-rw-r--r--generic/tclIndexObj.c44
-rw-r--r--generic/tclListObj.c106
-rw-r--r--generic/tclMain.c4
-rw-r--r--generic/tclVar.c7
-rw-r--r--tests/utf.test9
8 files changed, 130 insertions, 78 deletions
diff --git a/ChangeLog b/ChangeLog
index 28c66aa..567bfd2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,23 @@
+2011-08-16 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclCompile.c: [Bug 3392070] More complete prevention of
+ Tcl_Obj reference cycles when producing an intrep of ByteCode.
+
+2011-08-16 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclListObj.c (TclLindexList, TclLsetFlat): Silence warnings
+ about (unreachable) cases of uninitialized variables.
+ * generic/tclCmdIL.c (SelectObjFromSublist): Improve the generation of
+ * generic/tclIndexObj.c (Tcl_ParseArgsObjv): messages through the use
+ * generic/tclVar.c (ArrayStartSearchCmd): of Tcl_ObjPrintf.
+
2011-08-15 Don Porter <dgp@users.sourceforge.net>
- * generic/tclBasic.c: [Bug 3390272] Leak of [info script] value.
+ * generic/tclBasic.c: [Bug 3390272]: Leak of [info script] value.
2011-08-15 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclPosixStr.c: [Bug 3388350] mingw64 compiler warnings
+ * generic/tclPosixStr.c: [Bug 3388350]: mingw64 compiler warnings
* win/tclWinPort.h:
* win/configure.in
* win/configure
@@ -16,7 +29,7 @@
2011-08-12 Don Porter <dgp@users.sourceforge.net>
- * generic/tclPathObj.c: [Bug 3389764] Eliminate possibility that dup
+ * generic/tclPathObj.c: [Bug 3389764]: Eliminate possibility that dup
of a "path" value can create reference cycle.
2011-08-12 Donal K. Fellows <dkf@users.sf.net>
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 64348ad..95532d3 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -4446,12 +4446,9 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- char buffer[TCL_INTEGER_SPACE];
-
- TclFormatInt(buffer, index);
- Tcl_AppendResult(infoPtr->interp, "element ", buffer,
- " missing from sublist \"", TclGetString(objPtr), "\"",
- NULL);
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element %d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
"INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ae633ea..026503b 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2449,8 +2449,16 @@ TclInitByteCodeObj(
* a value contains a literal which is that same value.
* If this is allowed to happen, refcount decrements may not
* reach zero, and memory may leak. Bugs 467523, 3357771
+ *
+ * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
+ * on the string value, and do not call Tcl_DuplicateObj() so we
+ * can be sure we do not have any lingering cycles hiding in
+ * the intrep.
*/
- codePtr->objArrayPtr[i] = Tcl_DuplicateObj(objPtr);
+ int numBytes;
+ const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+
+ codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
Tcl_DecrRefCount(objPtr);
} else {
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 76c2dea..6f378a4 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -359,7 +359,6 @@ Tcl_GetIndexFromObjStruct(
int count;
TclNewObj(resultPtr);
- Tcl_SetObjResult(interp, resultPtr);
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
msg, " \"", key, NULL);
@@ -379,6 +378,7 @@ Tcl_GetIndexFromObjStruct(
}
}
}
+ Tcl_SetObjResult(interp, resultPtr);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
}
return TCL_ERROR;
@@ -410,7 +410,7 @@ SetIndexFromAny(
register Tcl_Obj *objPtr) /* The object to convert. */
{
if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't convert value to index except via Tcl_GetIndexFromObj API",
-1));
}
@@ -593,14 +593,16 @@ PrefixMatchObjCmd(
case PRFMATCH_MESSAGE:
if (i > (objc - 4)) {
Tcl_AppendResult(interp, "missing message", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
message = Tcl_GetString(objv[i]);
break;
case PRFMATCH_ERROR:
- if (i > (objc - 4)) {
+ if (i > objc-4) {
Tcl_AppendResult(interp, "missing error options", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
@@ -611,6 +613,7 @@ PrefixMatchObjCmd(
if ((errorLength % 2) != 0) {
Tcl_AppendResult(interp, "error options must have an even"
" number of elements", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
return TCL_ERROR;
}
errorPtr = objv[i];
@@ -1093,7 +1096,7 @@ Tcl_ParseArgsObjv(
/* Pointer to the current entry in the table
* of argument descriptions. */
const Tcl_ArgvInfo *matchPtr;
- /* Descriptor that matches current argument. */
+ /* Descriptor that matches current argument */
Tcl_Obj *curArg; /* Current argument */
const char *str = NULL;
register char c; /* Second character of current arg (used for
@@ -1106,7 +1109,7 @@ Tcl_ParseArgsObjv(
* being processed, primarily for error
* reporting. */
int objc; /* # arguments in objv still to process. */
- int length; /* Number of characters in current argument. */
+ int length; /* Number of characters in current argument */
if (remObjv != NULL) {
/*
@@ -1147,8 +1150,7 @@ Tcl_ParseArgsObjv(
matchPtr = NULL;
infoPtr = argTable;
- for (; (infoPtr != NULL) && (infoPtr->type != TCL_ARGV_END);
- infoPtr++) {
+ for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) {
if (infoPtr->keyStr == NULL) {
continue;
}
@@ -1242,7 +1244,8 @@ Tcl_ParseArgsObjv(
objc--;
break;
case TCL_ARGV_FUNC: {
- Tcl_ArgvFuncProc *handlerProc;
+ Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *)
+ infoPtr->srcPtr;
Tcl_Obj *argObj;
if (objc == 0) {
@@ -1250,7 +1253,6 @@ Tcl_ParseArgsObjv(
} else {
argObj = objv[srcIndex];
}
- handlerProc = (Tcl_ArgvFuncProc *) infoPtr->srcPtr;
if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
srcIndex++;
objc--;
@@ -1258,9 +1260,9 @@ Tcl_ParseArgsObjv(
break;
}
case TCL_ARGV_GENFUNC: {
- Tcl_ArgvGenFuncProc *handlerProc;
+ Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
+ infoPtr->srcPtr;
- handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr;
objc = handlerProc(infoPtr->clientData, interp, objc,
&objv[srcIndex], infoPtr->dstPtr);
if (objc < 0) {
@@ -1271,15 +1273,11 @@ Tcl_ParseArgsObjv(
case TCL_ARGV_HELP:
PrintUsage(interp, argTable);
goto error;
- default: {
- char buf[64 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "bad argument type %d in Tcl_ArgvInfo",
- infoPtr->type);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+ default:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad argument type %d in Tcl_ArgvInfo", infoPtr->type));
goto error;
}
- }
}
/*
@@ -1444,18 +1442,18 @@ int
TclGetCompletionCodeFromObj(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *value,
- int *code) /* Argument objects. */
+ int *code) /* Argument objects. */
{
static const char *const returnCodes[] = {
- "ok", "error", "return", "break", "continue", NULL
+ "ok", "error", "return", "break", "continue", NULL
};
if ((value->typePtr != &indexType)
&& (TCL_OK == TclGetIntFromObj(NULL, value, code))) {
return TCL_OK;
}
- if (TCL_OK == Tcl_GetIndexFromObj(
- NULL, value, returnCodes, NULL, TCL_EXACT, code)) {
+ if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL,
+ TCL_EXACT, code)) {
return TCL_OK;
}
/*
@@ -1472,7 +1470,7 @@ TclGetCompletionCodeFromObj(
}
return TCL_ERROR;
}
-
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index ac87628..3668b45 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -49,7 +49,6 @@ const Tcl_ObjType tclListType = {
#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif
-
/*
*----------------------------------------------------------------------
@@ -518,7 +517,10 @@ Tcl_ListObjAppendList(
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
- /* Pull the elements to append from elemListPtr */
+ /*
+ * Pull the elements to append from elemListPtr.
+ */
+
if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
return TCL_ERROR;
}
@@ -600,7 +602,10 @@ Tcl_ListObjAppendElement(
}
if (needGrow && !isShared) {
- /* Need to grow + unshared intrep => try to realloc */
+ /*
+ * Need to grow + unshared intrep => try to realloc
+ */
+
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
@@ -626,10 +631,10 @@ Tcl_ListObjAppendElement(
Tcl_Obj **dst, **src = &listRepPtr->elements;
/*
- * Either we have a shared intrep and we must copy to write,
- * or we need to grow and realloc attempts failed.
- * Attempt intrep copy.
+ * Either we have a shared intrep and we must copy to write, or we
+ * need to grow and realloc attempts failed. Attempt intrep copy.
*/
+
attempt = 2 * numRequired;
newPtr = AttemptNewList(NULL, attempt, NULL);
if (newPtr == NULL) {
@@ -644,7 +649,10 @@ Tcl_ListObjAppendElement(
newPtr = AttemptNewList(interp, attempt, NULL);
}
if (newPtr == NULL) {
- /* All growth attempts failed; throw the error */
+ /*
+ * All growth attempts failed; throw the error.
+ */
+
return TCL_ERROR;
}
@@ -655,8 +663,8 @@ Tcl_ListObjAppendElement(
if (isShared) {
/*
- * The original intrep must remain undisturbed.
- * Copy into the new one and bump refcounts
+ * The original intrep must remain undisturbed. Copy into the new
+ * one and bump refcounts
*/
while (numElems--) {
*dst = *src++;
@@ -664,9 +672,11 @@ Tcl_ListObjAppendElement(
}
listRepPtr->refCount--;
} else {
- /* Old intrep to be freed, re-use refCounts */
- memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
+ /*
+ * Old intrep to be freed, re-use refCounts.
+ */
+ memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
ckfree(listRepPtr);
}
listRepPtr = newPtr;
@@ -854,11 +864,10 @@ Tcl_ListObjReplace(
}
if (listPtr->typePtr != &tclListType) {
if (listPtr->bytes == tclEmptyStringRep) {
- if (objc) {
- Tcl_SetListObj(listPtr, objc, NULL);
- } else {
+ if (!objc) {
return TCL_OK;
}
+ Tcl_SetListObj(listPtr, objc, NULL);
} else {
int result = SetListFromAny(interp, listPtr);
@@ -891,8 +900,9 @@ Tcl_ListObjReplace(
} else if (numElems < first+count || first+count < 0) {
/*
* The 'first+count < 0' condition here guards agains integer
- * overflow in determining 'first+count'
+ * overflow in determining 'first+count'.
*/
+
count = numElems - first;
}
@@ -1075,8 +1085,6 @@ TclLindexList(
{
int index; /* Index into the list. */
- Tcl_Obj **indices; /* Array of list indices. */
- int indexCount; /* Size of the array of list indices. */
Tcl_Obj *indexListCopy;
/*
@@ -1116,8 +1124,19 @@ TclLindexList(
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
- TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
- listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
+ if (indexListCopy->typePtr == &tclListType) {
+ List *listRepPtr = ListRepPtr(indexListCopy);
+
+ listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
+ &listRepPtr->elements);
+ } else {
+ int indexCount = -1; /* Size of the array of list indices. */
+ Tcl_Obj **indices = NULL;
+ /* Array of list indices. */
+
+ Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
+ listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
+ }
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
@@ -1375,6 +1394,7 @@ TclLsetFlat(
retValuePtr = subListPtr;
chainPtr = NULL;
+ result = TCL_OK;
/*
* Loop through all the index arguments, and for each one dive into the
@@ -1385,11 +1405,14 @@ TclLsetFlat(
int elemCount;
Tcl_Obj *parentList, **elemPtrs;
- /* Check for the possible error conditions... */
- result = TCL_ERROR;
+ /*
+ * Check for the possible error conditions...
+ */
+
if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
!= TCL_OK) {
/* ...the sublist we're indexing into isn't a list at all. */
+ result = TCL_ERROR;
break;
}
@@ -1401,6 +1424,7 @@ TclLsetFlat(
if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
!= TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
+ result = TCL_ERROR;
indexArray++;
break;
}
@@ -1411,9 +1435,10 @@ TclLsetFlat(
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
+ "BADINDEX", NULL);
}
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
- NULL);
+ result = TCL_ERROR;
break;
}
@@ -1424,7 +1449,6 @@ TclLsetFlat(
* modify it.
*/
- result = TCL_OK;
if (--indexCount) {
parentList = subListPtr;
if (index == elemCount) {
@@ -1514,10 +1538,13 @@ TclLsetFlat(
}
/*
- * Store valuePtr in proper sublist and return.
+ * Store valuePtr in proper sublist and return. The -1 is to avoid a
+ * compiler warning (not a problem because we checked that we have a
+ * proper list - or something convertible to one - above).
*/
- Tcl_ListObjLength(NULL, subListPtr, &len);
+ len = -1;
+ TclListObjLength(NULL, subListPtr, &len);
if (index == len) {
Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
} else {
@@ -1586,9 +1613,9 @@ TclListObjSetElement(
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
+ "BADINDEX", NULL);
}
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
- NULL);
return TCL_ERROR;
}
result = SetListFromAny(interp, listPtr);
@@ -1811,19 +1838,23 @@ SetListFromAny(
*/
estCount = TclMaxListLength(nextElem, length, &limit);
- estCount += (estCount == 0); /* Smallest List struct holds 1 element. */
+ estCount += (estCount == 0); /* Smallest list struct holds 1
+ * element. */
listRepPtr = AttemptNewList(interp, estCount, NULL);
if (listRepPtr == NULL) {
return TCL_ERROR;
}
elemPtrs = &listRepPtr->elements;
- /* Each iteration, parse and store a list element */
+ /*
+ * Each iteration, parse and store a list element.
+ */
+
while (nextElem < limit) {
const char *elemStart;
int elemSize, literal;
- if (TCL_OK != TclFindElement(interp, nextElem, (limit - nextElem),
+ if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
while (--elemPtrs >= &listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
@@ -1904,7 +1935,9 @@ UpdateStringOfList(
listRepPtr->canonicalFlag = 1;
- /* Handle empty list case first, so rest of the routine is simpler */
+ /*
+ * Handle empty list case first, so rest of the routine is simpler.
+ */
if (numElems == 0) {
listPtr->bytes = tclEmptyStringRep;
@@ -1919,12 +1952,15 @@ UpdateStringOfList(
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- /* We know numElems <= LIST_MAX, so this is safe. */
+ /*
+ * We know numElems <= LIST_MAX, so this is safe.
+ */
+
flagPtr = ckalloc(numElems * sizeof(int));
}
elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
- flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
+ flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded < 0) {
@@ -1944,7 +1980,7 @@ UpdateStringOfList(
listPtr->bytes = ckalloc(bytesNeeded);
dst = listPtr->bytes;
for (i = 0; i < numElems; i++) {
- flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
+ flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 652074e..114d2c3 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -392,7 +392,7 @@ Tcl_MainEx(
/*
* Arrange for final deletion of the main interp
*/
- // ARGH Munchhausen effect
+ /* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp);
}
@@ -928,7 +928,7 @@ FreeMainInterp(
{
Tcl_Interp *interp = (Tcl_Interp *) clientData;
- //if (TclInExit()) return;
+ /*if (TclInExit()) return;*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 62bf1c4..4df5d43 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3077,21 +3077,18 @@ ArrayStartSearchCmd(
hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
if (isNew) {
searchPtr->id = 1;
- Tcl_AppendResult(interp, "s-1-", varName, NULL);
varPtr->flags |= VAR_SEARCH_ACTIVE;
searchPtr->nextPtr = NULL;
} else {
- char string[TCL_INTEGER_SPACE];
-
searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
- TclFormatInt(string, searchPtr->id);
- Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
}
searchPtr->varPtr = varPtr;
searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
&searchPtr->search);
Tcl_SetHashValue(hPtr, searchPtr);
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
return TCL_OK;
}
diff --git a/tests/utf.test b/tests/utf.test
index 0f1428f..81385bb 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -27,9 +27,12 @@ test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
set x "\u4e4e"
} [bytestring "\xe4\xb9\x8e"]
-test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
- string length [format %c -1]
-} 1
+test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} {
+ format %c 0x110000
+} [bytestring "\xef\xbf\xbd"]
+test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
+ format %c -1
+} [bytestring "\xef\xbf\xbd"]
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
generated by cgit v0.12 at 2024-11-09 21:38:44 (GMT)