Tcl Source Code

Check-in [762f581ae3]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Fix Valgrind "still reachable" report in TestcmdtokenCmd().
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | pyk-TestcmdtokenCmd
Files: files | file ages | folders
SHA3-256: 762f581ae336be9f3d4a0c6d6a3b99bb783739b4a969d62ccb260ee52f4142b6
User & Date: pooryorick 2023-03-03 12:15:11.199
Context
2023-03-05
07:11
A better fix for Valgrind "still reachable" report in TestcmdtokenCmd(). Closed-Leaf check-in: 4cdf1436d1 user: pooryorick tags: pyk-TestcmdtokenCmd
2023-03-03
12:39
Fix Valgrind "still reachable" report in TestcmdtokenCmd(). check-in: 69364e849f user: pooryorick tags: trunk, main
12:17
Fix Valgrind "still reachable" report in TestcmdtokenCmd(). check-in: 1170c0f0a8 user: pooryorick tags: core-8-branch
12:15
Fix Valgrind "still reachable" report in TestcmdtokenCmd(). check-in: 762f581ae3 user: pooryorick tags: pyk-TestcmdtokenCmd
2023-03-02
07:08
Disable more file permissions tests for WSL (not supported in WSL/NTFS) check-in: 547d467832 user: apnadkarni tags: core-8-branch
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/tclTest.c.
︙︙
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285



1286
1287
1288
1289
1290
1291
1292













1293
1294
1295
1296
1297


1298
1299
1300
1301
1302
1303
1304

static int
TestcmdtokenCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    TestCommandTokenRef *refPtr;
    char buf[30];
    int id;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option arg\"", NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "create") == 0) {
	refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef));
	refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
		(void *) "original", NULL);
	refPtr->id = nextCommandTokenRefId;
	nextCommandTokenRefId++;
	refPtr->nextPtr = firstCommandTokenRef;
	firstCommandTokenRef = refPtr;
	sprintf(buf, "%d", refPtr->id);
	Tcl_AppendResult(interp, buf, NULL);
    } else if (strcmp(argv[1], "name") == 0) {
	Tcl_Obj *objPtr;

	if (sscanf(argv[2], "%d", &id) != 1) {
	    Tcl_AppendResult(interp, "bad command token \"", argv[2],
		    "\"", NULL);
	    return TCL_ERROR;
	}

	for (refPtr = firstCommandTokenRef; refPtr != NULL;
		refPtr = refPtr->nextPtr) {
	    if (refPtr->id == id) {
		break;
	    }
	}

	if (refPtr == NULL) {
	    Tcl_AppendResult(interp, "bad command token \"", argv[2],
		    "\"", 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 {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create or name", NULL);
	return TCL_ERROR;
    }


    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestcmdtraceCmd --








|


















|
<
<



















>
>
>
|
|

|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
>
>








1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264


1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320

static int
TestcmdtokenCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    TestCommandTokenRef *refPtr, *prevRefPtr;
    char buf[30];
    int id;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option arg\"", NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "create") == 0) {
	refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef));
	refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
		(void *) "original", NULL);
	refPtr->id = nextCommandTokenRefId;
	nextCommandTokenRefId++;
	refPtr->nextPtr = firstCommandTokenRef;
	firstCommandTokenRef = refPtr;
	sprintf(buf, "%d", refPtr->id);
	Tcl_AppendResult(interp, buf, NULL);
    } else {


	if (sscanf(argv[2], "%d", &id) != 1) {
	    Tcl_AppendResult(interp, "bad command token \"", argv[2],
		    "\"", NULL);
	    return TCL_ERROR;
	}

	for (refPtr = firstCommandTokenRef; refPtr != NULL;
		refPtr = refPtr->nextPtr) {
	    if (refPtr->id == id) {
		break;
	    }
	}

	if (refPtr == NULL) {
	    Tcl_AppendResult(interp, "bad command token \"", argv[2],
		    "\"", NULL);
	    return TCL_ERROR;
	}

	if (strcmp(argv[1], "name") == 0) {
	    Tcl_Obj *objPtr;

	    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;
}

/*
 *----------------------------------------------------------------------
 *
 * TestcmdtraceCmd --
︙︙
Changes to tests/basic.test.
︙︙
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358

    unset -nocomplain x
    set x [namespace eval test_ns_basic::test_ns_basic2 {
        # the following creates a cmd in the global namespace
        testcmdtoken create p
    }]
    list [testcmdtoken name $x] \
         [rename ::p q] \
         [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]
} {{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
} {{#} ::#}

test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}

test basic-22.1 {Tcl_GetCommandFullName} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}








|






|




|








332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358

    unset -nocomplain x
    set x [namespace eval test_ns_basic::test_ns_basic2 {
        # the following creates a cmd in the global namespace
        testcmdtoken create p
    }]
    list [testcmdtoken name $x] \
         [rename ::p q] \
         [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 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 \#]
    return [testcmdtoken name $x][testcmdtoken free $x]
} {{#} ::#}

test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}

test basic-22.1 {Tcl_GetCommandFullName} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
︙︙
Changes to tests/cmdInfo.test.
︙︙
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109


test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} \
	{testcmdtoken} {
    set x [testcmdtoken create x1]
    rename x1 newName
    set y [testcmdtoken name $x]
    rename newName x1
    lappend y {*}[testcmdtoken name $x]
} {newName ::newName x1 ::x1}

catch {rename newTestCmd {}}
catch {rename newTestCmd2 {}}

test cmdinfo-5.1 {Names for commands created when inside namespaces} \
	{testcmdtoken} {
    # create namespace cmdInfoNs1
    namespace eval cmdInfoNs1 {}   ;# creates namespace cmdInfoNs1
    # create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it
    set x [namespace eval cmdInfoNs1::cmdInfoNs2 {
        # the following creates a cmd in the global namespace
        testcmdtoken create testCmd
    }]
    set y [testcmdtoken name $x]
    rename ::testCmd newTestCmd
    lappend y {*}[testcmdtoken name $x]
} {testCmd ::testCmd newTestCmd ::newTestCmd}

test cmdinfo-6.1 {Names for commands created when outside namespaces} \
	{testcmdtoken} {
    set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd]
    set y [testcmdtoken name $x]
    rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
    lappend y {*}[testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}

# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
cleanupTests
return

# Local Variables:
# mode: tcl
# End:








|
















|







|












66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109


test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} \
	{testcmdtoken} {
    set x [testcmdtoken create x1]
    rename x1 newName
    set y [testcmdtoken name $x]
    rename newName x1
    lappend y {*}[testcmdtoken name $x][testcmdtoken free $x]
} {newName ::newName x1 ::x1}

catch {rename newTestCmd {}}
catch {rename newTestCmd2 {}}

test cmdinfo-5.1 {Names for commands created when inside namespaces} \
	{testcmdtoken} {
    # create namespace cmdInfoNs1
    namespace eval cmdInfoNs1 {}   ;# creates namespace cmdInfoNs1
    # create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it
    set x [namespace eval cmdInfoNs1::cmdInfoNs2 {
        # the following creates a cmd in the global namespace
        testcmdtoken create testCmd
    }]
    set y [testcmdtoken name $x]
    rename ::testCmd newTestCmd
    lappend y {*}[testcmdtoken name $x][testcmdtoken free $x]
} {testCmd ::testCmd newTestCmd ::newTestCmd}

test cmdinfo-6.1 {Names for commands created when outside namespaces} \
	{testcmdtoken} {
    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]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}

# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
This page was generated in about 0.025s by Fossil 2.26 [54cfac8c84] 2025-03-21 15:26:53