Tcl Source Code

Check-in [06c0436f04]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:
* generic/tclIndexObj.c (Tcl_ParseArgsObjv): [Bug 3413857]: Corrected the memory management for the code parsing arguments when returning "large" numbers of arguments. Also unbroke the TCL_ARGV_AUTO_REST macro in passing.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 06c0436f0421b3ee5c7fac0bd919e7dde362d3a6
User & Date: dkf 2011-09-27 09:49:06
Context
2011-09-27
09:57
Release unused memory... check-in: 538047ebb7 user: dkf tags: trunk
09:49
* generic/tclIndexObj.c (Tcl_ParseArgsObjv): [Bug 3413857]: Corrected the memory management for th...
check-in: 06c0436f04 user: dkf tags: trunk
09:45
Test harness for Tcl_ParseArgsObjv Closed-Leaf check-in: ffc52b181f user: dkf tags: bug-3413857
2011-09-26
10:46
Make [file] itself be safe, to reduce breakage in existing code. [Bug 3211758] check-in: 08c3728274 user: dkf tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.








1
2
3
4
5
6
7






2011-09-26  Donal K. Fellows  <[email protected]>

	* generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also
	make the main [file] command hidden by default in safe interpreters,
	because that's what existing code expects. This will reduce the amount
	which the code breaks, but not necessarily eliminate it...

>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
2011-09-27  Donal K. Fellows  <[email protected]>

	* generic/tclIndexObj.c (Tcl_ParseArgsObjv): [Bug 3413857]: Corrected
	the memory management for the code parsing arguments when returning
	"large" numbers of arguments. Also unbroke the TCL_ARGV_AUTO_REST
	macro in passing.

2011-09-26  Donal K. Fellows  <[email protected]>

	* generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also
	make the main [file] command hidden by default in safe interpreters,
	because that's what existing code expects. This will reduce the amount
	which the code breaks, but not necessarily eliminate it...

Changes to generic/tclIndexObj.c.

1109
1110
1111
1112
1113
1114
1115
1116



1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
....
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
....
1223
1224
1225
1226
1227
1228
1229






1230

1231
1232
1233
1234
1235
1236
1237
....
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
				 * being processed, primarily for error
				 * reporting. */
    int objc;			/* # arguments in objv still to process. */
    int length;			/* Number of characters in current argument */

    if (remObjv != NULL) {
	/*
	 * Then we should copy the name of the command (0th argument).



	 */

	nrem = 1;
	leftovers = ckalloc((nrem + 1) * sizeof(Tcl_Obj *));
	leftovers[nrem-1] = objv[0];
	leftovers[nrem] = NULL;
    } else {
	nrem = 0;
	leftovers = NULL;
    }

    /*
     * OK, now start processing from the second element (1st argument).
................................................................................
	    if (remObjv == NULL) {
		Tcl_AppendResult(interp, "unrecognized argument \"", str,
			"\"", NULL);
		goto error;
	    }

	    dstIndex++;		/* This argument is now handled */
	    nrem++;

	    /*
	     * Allocate nrem (+1 extra for NULL terminator) pointers.
	     */

	    leftovers = ckrealloc(leftovers, (nrem+1) * sizeof(Tcl_Obj *));
	    leftovers[nrem-1] = curArg;
	    continue;
	}

	/*
	 * Take the appropriate action based on the option type
	 */

................................................................................
	    }
	    *((const char **) infoPtr->dstPtr) =
		    Tcl_GetString(objv[srcIndex]);
	    srcIndex++;
	    objc--;
	    break;
	case TCL_ARGV_REST:






	    *((int *) infoPtr->dstPtr) = dstIndex;

	    goto argsDone;
	case TCL_ARGV_FLOAT:
	    if (objc == 0) {
		goto missingArg;
	    }
	    if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
		    (double *) infoPtr->dstPtr) == TCL_ERROR) {
................................................................................
		    "bad argument type %d in Tcl_ArgvInfo", infoPtr->type));
	    goto error;
	}
    }

    /*
     * If we broke out of the loop because of an OPT_REST argument, copy the
     * remaining arguments down.


     */

  argsDone:
    if (remObjv == NULL) {
	/*
	 * Nothing to do.
	 */

	return TCL_OK;
    }

    if (objc > 0) {
	leftovers = ckrealloc(leftovers, (nrem+objc+1) * sizeof(Tcl_Obj *));
	while (objc) {
	    leftovers[nrem] = objv[srcIndex];
	    nrem++;
	    srcIndex++;
	    objc--;
	}
    } else if (leftovers != NULL) {
	ckfree(leftovers);
    }
    leftovers[nrem] = NULL;
    *objcPtr = nrem;
    *remObjv = leftovers;

    return TCL_OK;

    /*
     * Make sure to handle freeing any temporary space we've allocated on the
     * way to an error.
     */







|
>
>
>



|
|
<







 







<
<
<
<
<
<
<
|







 







>
>
>
>
>
>
|
>







 







|
>
>












|
<
<
|
<
<
|
<
<
<

|
<
>







1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124

1125
1126
1127
1128
1129
1130
1131
....
1180
1181
1182
1183
1184
1185
1186







1187
1188
1189
1190
1191
1192
1193
1194
....
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
....
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
				 * being processed, primarily for error
				 * reporting. */
    int objc;			/* # arguments in objv still to process. */
    int length;			/* Number of characters in current argument */

    if (remObjv != NULL) {
	/*
	 * Then we should copy the name of the command (0th argument). The
	 * upper bound on the number of elements is known, and (undocumented,
	 * but historically true) there should be a NULL argument after the
	 * last result. [Bug 3413857]
	 */

	nrem = 1;
	leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
	leftovers[0] = objv[0];

    } else {
	nrem = 0;
	leftovers = NULL;
    }

    /*
     * OK, now start processing from the second element (1st argument).
................................................................................
	    if (remObjv == NULL) {
		Tcl_AppendResult(interp, "unrecognized argument \"", str,
			"\"", NULL);
		goto error;
	    }

	    dstIndex++;		/* This argument is now handled */







	    leftovers[nrem++] = curArg;
	    continue;
	}

	/*
	 * Take the appropriate action based on the option type
	 */

................................................................................
	    }
	    *((const char **) infoPtr->dstPtr) =
		    Tcl_GetString(objv[srcIndex]);
	    srcIndex++;
	    objc--;
	    break;
	case TCL_ARGV_REST:
	    /*
	     * Only store the point where we got to if it's not to be written
	     * to NULL, so that TCL_ARGV_AUTO_REST works.
	     */

	    if (infoPtr->dstPtr != NULL) {
		*((int *) infoPtr->dstPtr) = dstIndex;
	    }
	    goto argsDone;
	case TCL_ARGV_FLOAT:
	    if (objc == 0) {
		goto missingArg;
	    }
	    if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
		    (double *) infoPtr->dstPtr) == TCL_ERROR) {
................................................................................
		    "bad argument type %d in Tcl_ArgvInfo", infoPtr->type));
	    goto error;
	}
    }

    /*
     * If we broke out of the loop because of an OPT_REST argument, copy the
     * remaining arguments down. Note that there is always at least one
     * argument left over - the command name - so we always have a result if
     * our caller is willing to receive it. [Bug 3413857]
     */

  argsDone:
    if (remObjv == NULL) {
	/*
	 * Nothing to do.
	 */

	return TCL_OK;
    }

    if (objc > 0) {
	memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));


	nrem += objc;


    }



    leftovers[nrem] = NULL;
    *objcPtr = nrem++;

    *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *));
    return TCL_OK;

    /*
     * Make sure to handle freeing any temporary space we've allocated on the
     * way to an error.
     */

Changes to generic/tclTest.c.

307
308
309
310
311
312
313


314
315
316
317
318
319
320
...
620
621
622
623
624
625
626

627
628
629
630
631
632
633
....
7076
7077
7078
7079
7080
7081
7082










































7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
static int		TestexitmainloopCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestpanicCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestfinexitObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);


static int		TestparserObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestparsevarObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestparsevarnameObjCmd(ClientData dummy,
................................................................................
    Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
	    NULL);
    Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);

    Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
................................................................................
    Tcl_DecrRefCount(tmpPtr);

    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;
}










































 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */






>
>







 







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
....
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
static int		TestexitmainloopCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestpanicCmd(ClientData dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestfinexitObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int              TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
                            int objc, Tcl_Obj *const objv[]);
static int		TestparserObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestparsevarObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestparsevarnameObjCmd(ClientData dummy,
................................................................................
    Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
	    NULL);
    Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
    Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
................................................................................
    Tcl_DecrRefCount(tmpPtr);

    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TestparseargsCmd --
 *
 *	This procedure implements the "testparseargs" command. It is used to
 *	test that Tcl_ParseArgsObjv does indeed return the right number of
 *	arguments. In other words, that [Bug 3413857] was fixed properly.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestparseargsCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Arguments. */
{
    int count = objc, foo = 0;
    Tcl_Obj **remObjv, *result[3];
    Tcl_ArgvInfo argTable[] = {
        {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
        TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
    };

    if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
        return TCL_ERROR;
    }
    result[0] = Tcl_NewIntObj(foo);
    result[1] = Tcl_NewIntObj(count);
    result[2] = Tcl_NewListObj(count, remObjv);
    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */

Changes to tests/indexObj.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
...
124
125
126
127
128
129
130

























131
132
133
134
135
136
137
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups.  The tests here
# are organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testindexobj [llength [info commands testindexobj]]


test indexObj-1.1 {exact match} testindexobj {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
    testindexobj 1 1 abc abc def xyz alm
} {0}
test indexObj-1.3 {exact match} testindexobj {
................................................................................
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj {
    set x c
    testgetindexfromobjstruct $x 1
    testgetindexfromobjstruct $x 1
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""


























# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:
|
|




|
|


|




>
|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups.  The tests here are
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
 
test indexObj-1.1 {exact match} testindexobj {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} testindexobj {
    testindexobj 1 1 abc abc def xyz alm
} {0}
test indexObj-1.3 {exact match} testindexobj {
................................................................................
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj {
    set x c
    testgetindexfromobjstruct $x 1
    testgetindexfromobjstruct $x 1
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""

test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
    testparseargs
} {0 1 testparseargs}
test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
    testparseargs -bool
} {1 1 testparseargs}
test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
    testparseargs -bool bar
} {1 2 {testparseargs bar}}
test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
    testparseargs bar
} {0 2 {testparseargs bar}}
test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
    testparseargs -help
} -returnCodes error -result {Command-specific options:
 -bool: booltest
 --:    Marks the end of the options
 -help: Print summary of command-line options and abort}
test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs {
    testparseargs -- -bool -help
} {0 3 {testparseargs -bool -help}}
test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs {
    testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0
} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}}
 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: