From d3aa6839f45e33d533ae9525378612cb04ab0dd1 Mon Sep 17 00:00:00 2001
From: pooryorick <com.digitalsmarties@pooryorick.com>
Date: Fri, 3 Mar 2023 12:15:11 +0000
Subject: Fix Valgrind "still reachable" report in TestcmdtokenCmd().

---
 generic/tclTest.c  | 44 ++++++++++++++++++++++++++++++--------------
 tests/basic.test   |  6 +++---
 tests/cmdInfo.test |  6 +++---
 3 files changed, 36 insertions(+), 20 deletions(-)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index f4450ff..fbd4774 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -1242,7 +1242,7 @@ TestcmdtokenCmd(
     int argc,			/* Number of arguments. */
     const char **argv)		/* Argument strings. */
 {
-    TestCommandTokenRef *refPtr;
+    TestCommandTokenRef *refPtr, *prevRefPtr;
     char buf[30];
     int id;
 
@@ -1261,9 +1261,7 @@ TestcmdtokenCmd(
 	firstCommandTokenRef = refPtr;
 	sprintf(buf, "%d", refPtr->id);
 	Tcl_AppendResult(interp, buf, NULL);
-    } else if (strcmp(argv[1], "name") == 0) {
-	Tcl_Obj *objPtr;
-
+    } else {
 	if (sscanf(argv[2], "%d", &id) != 1) {
 	    Tcl_AppendResult(interp, "bad command token \"", argv[2],
 		    "\"", NULL);
@@ -1283,18 +1281,36 @@ TestcmdtokenCmd(
 	    return TCL_ERROR;
 	}
 
-	objPtr = Tcl_NewObj();
-	Tcl_GetCommandFullName(interp, refPtr->token, objPtr);
+	if (strcmp(argv[1], "name") == 0) {
+	    Tcl_Obj *objPtr;
 
-	Tcl_AppendElement(interp,
-		Tcl_GetCommandName(interp, refPtr->token));
-	Tcl_AppendElement(interp, Tcl_GetString(objPtr));
-	Tcl_DecrRefCount(objPtr);
-    } else {
-	Tcl_AppendResult(interp, "bad option \"", argv[1],
-		"\": must be create or name", NULL);
-	return TCL_ERROR;
+	    objPtr = Tcl_NewObj();
+	    Tcl_GetCommandFullName(interp, refPtr->token, objPtr);
+
+	    Tcl_AppendElement(interp,
+		    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);
+	    return TCL_ERROR;
+	}
     }
+
     return TCL_OK;
 }
 
diff --git a/tests/basic.test b/tests/basic.test
index f4c57fe..de986c7 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 name $x][testcmdtoken free $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 name $x][testcmdtoken free $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 \#]
-    testcmdtoken name $x
+    return [testcmdtoken name $x][testcmdtoken free $x]
 } {{#} ::#}
 
 test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index 37b8a0b..ad564d7 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]
+    lappend y {*}[testcmdtoken name $x][testcmdtoken free $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]
+    lappend y {*}[testcmdtoken name $x][testcmdtoken free $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]
+    lappend y {*}[testcmdtoken name $x][testcmdtoken free $x]
 } {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}
 
 # cleanup
-- 
cgit v0.12