summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2003-12-02 09:31:54 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2003-12-02 09:31:54 (GMT)
commitf7f2bef7e0fed017b7ed43ce94cf1154e791188c (patch)
tree8e65dcc29a152b1ac1461c0e10986ed1b7fd96dc
parent481bf0fb0bdd82a1f9b5a287dbe7c06de435804e (diff)
downloadtcl-f7f2bef7e0fed017b7ed43ce94cf1154e791188c.zip
tcl-f7f2bef7e0fed017b7ed43ce94cf1154e791188c.tar.gz
tcl-f7f2bef7e0fed017b7ed43ce94cf1154e791188c.tar.bz2
Stop losing references when variables are repeated in [binary scan]. [851747]
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclBinary.c111
-rw-r--r--tests/binary.test10
3 files changed, 87 insertions, 41 deletions
diff --git a/ChangeLog b/ChangeLog
index c67aa9b..16d6f60 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2003-12-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclBinary.c (DeleteScanNumberCache, ScanNumber): Made
+ the numeric scan-value cache have proper references to the objects
+ within it so strange patterns of writes won't cause references to
+ freed objects. [Bug 851747]
+
2003-12-01 Miguel Sofer <msofer@users.sf.net>
* doc/lset.n: fix typo [Bug 852224]
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 4dfb505..6769b4e 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBinary.c,v 1.13 2003/02/21 21:54:11 dkf Exp $
+ * RCS: @(#) $Id: tclBinary.c,v 1.13.2.1 2003/12/02 09:31:54 dkf Exp $
*/
#include "tclInt.h"
@@ -61,7 +61,8 @@ static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer,
static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
-
+static void DeleteScanNumberCache _ANSI_ARGS_((
+ Tcl_HashTable *numberCachePtr));
/*
* The following object type represents an array of bytes. An array of
@@ -751,7 +752,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
default: {
errorString = str;
- goto badfield;
+ goto badField;
}
}
}
@@ -1050,9 +1051,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
unsigned char *src;
if (arg >= objc) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
@@ -1086,9 +1085,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
@@ -1101,9 +1098,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
char *dest;
if (arg >= objc) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
@@ -1145,9 +1140,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
@@ -1162,9 +1155,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
static char hexdigit[] = "0123456789abcdef";
if (arg >= objc) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
@@ -1206,9 +1197,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
@@ -1246,9 +1235,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
scanNumber:
if (arg >= objc) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
@@ -1281,9 +1268,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
@@ -1314,9 +1299,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
case '@': {
if (count == BINARY_NOCOUNT) {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
goto badCount;
}
if ((count == BINARY_ALL) || (count > length)) {
@@ -1327,11 +1310,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
break;
}
default: {
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
errorString = str;
- goto badfield;
+ goto badField;
}
}
}
@@ -1343,9 +1324,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
done:
Tcl_ResetResult(interp);
Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
- if (numberCachePtr != NULL) {
- Tcl_DeleteHashTable(numberCachePtr);
- }
+ DeleteScanNumberCache(numberCachePtr);
break;
}
}
@@ -1365,7 +1344,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
errorString = "not enough arguments for all format specifiers";
goto error;
- badfield: {
+ badField:
+ {
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
@@ -1667,16 +1647,22 @@ ScanNumber(buffer, type, numberCachePtrPtr)
* Note that anyone just using the 'c' conversion
* (for bytes) cannot trigger this.
*/
- Tcl_DeleteHashTable(tablePtr);
+ DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
return Tcl_NewLongObj(value);
} else {
register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
- /* Don't need to fiddle with refcount... */
+
+ Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, (ClientData) objPtr);
return objPtr;
}
}
+
+ /*
+ * Do not cache wide values; they are already too large to
+ * use as keys.
+ */
case 'w':
uwvalue = ((Tcl_WideUInt) buffer[0])
| (((Tcl_WideUInt) buffer[1]) << 8)
@@ -1697,6 +1683,12 @@ ScanNumber(buffer, type, numberCachePtrPtr)
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
+
+ /*
+ * Do not cache double values; they are already too large
+ * to use as keys and the values stored are utterly
+ * incompatible too.
+ */
case 'f': {
float fvalue;
memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
@@ -1710,3 +1702,42 @@ ScanNumber(buffer, type, numberCachePtrPtr)
}
return NULL;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteScanNumberCache --
+ *
+ * Deletes the hash table acting as a scan number cache.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Decrements the reference counts of the objects in the cache.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteScanNumberCache(numberCachePtr)
+ Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or
+ * NULL (when the cache has already
+ * been deleted due to overflow.) */
+{
+ Tcl_HashEntry *hEntry;
+ Tcl_HashSearch search;
+
+ if (numberCachePtr == NULL) {
+ return;
+ }
+
+ hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
+ while (hEntry != NULL) {
+ register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);
+
+ Tcl_DecrRefCount(value);
+ hEntry = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(numberCachePtr);
+}
diff --git a/tests/binary.test b/tests/binary.test
index fcc6df6..98eb4fc 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: binary.test,v 1.11.2.1 2003/07/11 21:18:55 dkf Exp $
+# RCS: @(#) $Id: binary.test,v 1.11.2.2 2003/12/02 09:31:54 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1516,6 +1516,14 @@ test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
list $x $y [encoding convertfrom iso8859-15 $y]
} "1 \u00a4 \u20ac"
+test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} {
+ # This test is only reliable when memory debugging is turned on,
+ # but without even memory debugging it should still generate the
+ # expected answers and might therefore still pick up memory corruption
+ # caused by [Bug 851747].
+ list [binary scan aba ccc x x x] $x
+} {3 97}
+
# cleanup
::tcltest::cleanupTests
return