A better fix for Valgrind "still reachable" report in TestcmdtokenCmd().

3 files changed, 46 insertions, 22 deletions

diff --git a/generic/tclTest.c b/generic/tclTest.c
index fbd4774..5b57157 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -70,6 +70,7 @@ static Tcl_Interp *delInterp;
 typedef struct TestCommandTokenRef {
     int id;			/* Identifier for this reference. */
     Tcl_Command token;		/* Tcl's token for the command. */
+    const char *value;
     struct TestCommandTokenRef *nextPtr;
 				/* Next in list of references. */
 } TestCommandTokenRef;
@@ -1179,6 +1180,18 @@ TestcmdinfoCmd(
 }
 
 static int
+CmdProc0(
+    void *clientData,	/* String to return. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    TCL_UNUSED(int) /*argc*/,
+    TCL_UNUSED(const char **) /*argv*/)
+{
+    TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData;
+    Tcl_AppendResult(interp, "CmdProc1 ", refPtr->value, NULL);
+    return TCL_OK;
+}
+
+static int
 CmdProc1(
     void *clientData,	/* String to return. */
     Tcl_Interp *interp,		/* Current interpreter. */
@@ -1189,6 +1202,7 @@ CmdProc1(
     return TCL_OK;
 }
 
+
 static int
 CmdProc2(
     void *clientData,	/* String to return. */
@@ -1201,6 +1215,28 @@ CmdProc2(
 }
 
 static void
+CmdDelProc0(
+    void *clientData)	/* String to save. */
+{
+    TestCommandTokenRef *thisRefPtr, *prevRefPtr = NULL;
+    TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData;
+    int id = refPtr->id;
+    for (thisRefPtr = firstCommandTokenRef; refPtr != NULL;
+	thisRefPtr = thisRefPtr->nextPtr) {
+	if (thisRefPtr->id == id) {
+	    if (prevRefPtr != NULL) {
+		prevRefPtr->nextPtr = thisRefPtr->nextPtr;
+	    } else {
+		firstCommandTokenRef = thisRefPtr->nextPtr; 
+	    }
+	    break;
+	}
+	prevRefPtr = thisRefPtr;
+    }
+    ckfree(refPtr);
+}
+
+static void
 CmdDelProc1(
     void *clientData)	/* String to save. */
 {
@@ -1242,7 +1278,7 @@ TestcmdtokenCmd(
     int argc,			/* Number of arguments. */
     const char **argv)		/* Argument strings. */
 {
-    TestCommandTokenRef *refPtr, *prevRefPtr;
+    TestCommandTokenRef *refPtr;
     char buf[30];
     int id;
 
@@ -1253,9 +1289,10 @@ TestcmdtokenCmd(
     }
     if (strcmp(argv[1], "create") == 0) {
 	refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef));
-	refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
-		(void *) "original", NULL);
+	refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc0,
+		refPtr, CmdDelProc0);
 	refPtr->id = nextCommandTokenRefId;
+	refPtr->value = "original";
 	nextCommandTokenRefId++;
 	refPtr->nextPtr = firstCommandTokenRef;
 	firstCommandTokenRef = refPtr;
@@ -1291,19 +1328,6 @@ TestcmdtokenCmd(
 		    Tcl_GetCommandName(interp, refPtr->token));
 	    Tcl_AppendElement(interp, Tcl_GetString(objPtr));
 	    Tcl_DecrRefCount(objPtr);
-	} else if (strcmp(argv[1], "free") == 0) {
-	    prevRefPtr = NULL;
-	    for (refPtr = firstCommandTokenRef; refPtr != NULL;
-		    refPtr = refPtr->nextPtr) {
-		if (refPtr->id == id) {
-		    if (prevRefPtr != NULL) {
-			prevRefPtr->nextPtr = refPtr->nextPtr;
-		    }
-		    ckfree(refPtr);
-		    break;
-		}
-		prevRefPtr = refPtr;
-	    }
 	} else {
 	    Tcl_AppendResult(interp, "bad option \"", argv[1],
 		    "\": must be create, name, or free", NULL);
diff --git a/tests/basic.test b/tests/basic.test
index de986c7..c90d80e 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -336,19 +336,19 @@ test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespace
     }]
     list [testcmdtoken name $x] \
          [rename ::p q] \
-         [testcmdtoken name $x][testcmdtoken free $x]
+         [testcmdtoken name $x]
 } {{p ::p} {} {q ::q}}
 test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
     catch {rename q ""}
     set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
     list [testcmdtoken name $x] \
          [rename test_ns_basic::test_ns_basic2::p q] \
-         [testcmdtoken name $x][testcmdtoken free $x]
+         [testcmdtoken name $x]
 } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
 test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken {
     catch {rename \# ""}
     set x [testcmdtoken create \#]
-    return [testcmdtoken name $x][testcmdtoken free $x]
+    return [testcmdtoken name $x]
 } {{#} ::#}
 
 test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index ad564d7..37b8a0b 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -70,7 +70,7 @@ test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} \
     rename x1 newName
     set y [testcmdtoken name $x]
     rename newName x1
-    lappend y {*}[testcmdtoken name $x][testcmdtoken free $x]
+    lappend y {*}[testcmdtoken name $x]
 } {newName ::newName x1 ::x1}
 
 catch {rename newTestCmd {}}
@@ -87,7 +87,7 @@ test cmdinfo-5.1 {Names for commands created when inside namespaces} \
     }]
     set y [testcmdtoken name $x]
     rename ::testCmd newTestCmd
-    lappend y {*}[testcmdtoken name $x][testcmdtoken free $x]
+    lappend y {*}[testcmdtoken name $x]
 } {testCmd ::testCmd newTestCmd ::newTestCmd}
 
 test cmdinfo-6.1 {Names for commands created when outside namespaces} \
@@ -95,7 +95,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \
     set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd]
     set y [testcmdtoken name $x]
     rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
-    lappend y {*}[testcmdtoken name $x][testcmdtoken free $x]
+    lappend y {*}[testcmdtoken name $x]
 } {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}
 
 # cleanup