summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCkalloc.c196
-rw-r--r--generic/tclCmdMZ.c81
-rw-r--r--generic/tclIO.c35
-rw-r--r--generic/tclIOCmd.c4
-rw-r--r--generic/tclIndexObj.c3
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclTimer.c2
-rw-r--r--tests/ioCmd.test29
-rw-r--r--tests/string.test2
-rw-r--r--tests/stringComp.test2
-rw-r--r--tests/timer.test4
11 files changed, 185 insertions, 181 deletions
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 70e64f0..42c878f 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -132,9 +132,9 @@ static int ckallocInit = 0;
*/
static int CheckmemCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, const char *argv[]);
+ int argc, Tcl_Obj *const argv[]);
static int MemoryCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, const char *argv[]);
+ int argc, Tcl_Obj *const argv[]);
static void ValidateMemory(struct mem_header *memHeaderP,
const char *file, int line, int nukeGuards);
@@ -814,28 +814,41 @@ MemoryCmd(
ClientData clientData,
Tcl_Interp *interp,
int argc,
- const char *argv[])
+ Tcl_Obj *const argv[])
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
- int result;
+ int result, idx;
size_t len;
+ static const char *subcommands[] = {
+ "active", "display", "break_on_malloc", "info", "init", "objs",
+ "onexit", "tag", "trace", "trace_on_at_malloc", "validate",
+ NULL
+ };
+ enum MemSubcommands {
+ OPT_ACTIVE, OPT_DISPLAY, OPT_BREAK, OPT_INFO, OPT_INIT, OPT_OBJS,
+ OPT_ONEXIT, OPT_TAG, OPT_TRACE, OPT_TRACEON, OPT_VALIDATE
+ };
if (argc < 2) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s option [args..]\"", argv[0]));
+ Tcl_WrongNumArgs(interp, 1, argv, "option [args..]");
return TCL_ERROR;
}
- if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) {
+ if (Tcl_GetIndexFromObj(interp, argv[1], subcommands, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum MemSubcommands) idx) {
+ case OPT_ACTIVE:
+ case OPT_DISPLAY:
if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s file\"",
- argv[0], argv[1]));
- return TCL_ERROR;
+ goto missingFile;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, Tcl_GetString(argv[2]),
+ &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -843,21 +856,18 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
- argv[2], Tcl_PosixError(interp)));
+ Tcl_GetString(argv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
- }
- if (strcmp(argv[1],"break_on_malloc") == 0) {
+
+ case OPT_BREAK:
if (argc != 3) {
- goto argError;
+ goto missingCount;
}
- if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
- return TCL_ERROR;
- }
- return TCL_OK;
- }
- if (strcmp(argv[1],"info") == 0) {
+ return Tcl_GetIntFromObj(interp, argv[2], &break_on_malloc);
+
+ case OPT_INFO:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
"total mallocs", total_mallocs, "total frees", total_frees,
@@ -866,21 +876,19 @@ MemoryCmd(
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
return TCL_OK;
- }
- if (strcmp(argv[1], "init") == 0) {
+
+ case OPT_INIT:
if (argc != 3) {
- goto bad_suboption;
+ goto missingBoolean;
}
- init_malloced_bodies = (strcmp(argv[2],"on") == 0);
- return TCL_OK;
- }
- if (strcmp(argv[1], "objs") == 0) {
+ return Tcl_GetBooleanFromObj(interp, argv[2], &init_malloced_bodies);
+
+ case OPT_OBJS:
if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s objs file\"", argv[0]));
- return TCL_ERROR;
+ goto missingFile;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, Tcl_GetString(argv[2]),
+ &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -895,14 +903,13 @@ MemoryCmd(
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
- }
- if (strcmp(argv[1],"onexit") == 0) {
+
+ case OPT_ONEXIT:
if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s onexit file\"", argv[0]));
- return TCL_ERROR;
+ goto missingFile;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, Tcl_GetString(argv[2]),
+ &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -910,61 +917,50 @@ MemoryCmd(
strcpy(onExitMemDumpFileName,fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
- }
- if (strcmp(argv[1],"tag") == 0) {
+
+ case OPT_TAG:
if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s tag string\"", argv[0]));
+ Tcl_WrongNumArgs(interp, 2, argv, "string");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree((char *) curTagPtr);
}
- len = strlen(argv[2]);
+ len = strlen(Tcl_GetString(argv[2]));
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
- memcpy(curTagPtr->string, argv[2], len + 1);
+ memcpy(curTagPtr->string, Tcl_GetString(argv[2]), len + 1);
return TCL_OK;
- }
- if (strcmp(argv[1],"trace") == 0) {
+
+ case OPT_TRACE:
if (argc != 3) {
- goto bad_suboption;
+ goto missingBoolean;
}
- alloc_tracing = (strcmp(argv[2],"on") == 0);
- return TCL_OK;
- }
+ return Tcl_GetBooleanFromObj(interp, argv[2], &alloc_tracing);
- if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
+ case OPT_TRACEON:
if (argc != 3) {
- goto argError;
+ goto missingCount;
}
- if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
- return TCL_ERROR;
- }
- return TCL_OK;
- }
- if (strcmp(argv[1],"validate") == 0) {
+ return Tcl_GetIntFromObj(interp, argv[2], &trace_on_at_malloc);
+
+ case OPT_VALIDATE:
if (argc != 3) {
- goto bad_suboption;
+ goto missingBoolean;
}
- validate_memory = (strcmp(argv[2],"on") == 0);
- return TCL_OK;
+ return Tcl_GetBooleanFromObj(interp, argv[2], &validate_memory);
}
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad option \"%s\": should be active, break_on_malloc, info, "
- "init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
- argv[1]));
+ missingCount:
+ Tcl_WrongNumArgs(interp, 2, argv, "count");
return TCL_ERROR;
- argError:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
+ missingFile:
+ Tcl_WrongNumArgs(interp, 2, argv, "file");
return TCL_ERROR;
- bad_suboption:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
+ missingBoolean:
+ Tcl_WrongNumArgs(interp, 2, argv, "on|off");
return TCL_ERROR;
}
@@ -991,15 +987,23 @@ CheckmemCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter for evaluation. */
int argc, /* Number of arguments. */
- const char *argv[]) /* String values of arguments. */
+ Tcl_Obj *const argv[]) /* Values of arguments. */
{
+ char *bytes;
+ int len;
+
if (argc != 2) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s fileName\"", argv[0]));
+ Tcl_WrongNumArgs(interp, 1, argv, "fileName");
return TCL_ERROR;
}
+ bytes = Tcl_GetStringFromObj(argv[1], &len);
+ if (len > 99) {
+ Tcl_SetResult(interp, "string too long for internal buffer",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
tclMemDumpFileName = dumpFile;
- strcpy(tclMemDumpFileName, argv[1]);
+ strcpy(tclMemDumpFileName, bytes);
return TCL_OK;
}
@@ -1025,8 +1029,8 @@ Tcl_InitMemory(
* added */
{
TclInitDbCkalloc();
- Tcl_CreateCommand(interp, "memory", MemoryCmd, NULL, NULL);
- Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
@@ -1054,9 +1058,7 @@ char *
Tcl_Alloc(
unsigned int size)
{
- char *result;
-
- result = TclpAlloc(size);
+ char *result = (char *) TclpAlloc(size);
/*
* Most systems will not alloc(0), instead bumping it to one so that NULL
@@ -1080,9 +1082,7 @@ Tcl_DbCkalloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpAlloc(size);
+ char *result = (char *) TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
@@ -1106,10 +1106,7 @@ char *
Tcl_AttemptAlloc(
unsigned int size)
{
- char *result;
-
- result = TclpAlloc(size);
- return result;
+ return (char *) TclpAlloc(size);
}
char *
@@ -1118,10 +1115,7 @@ Tcl_AttemptDbCkalloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpAlloc(size);
- return result;
+ return (char *) TclpAlloc(size);
}
/*
@@ -1140,9 +1134,7 @@ Tcl_Realloc(
char *ptr,
unsigned int size)
{
- char *result;
-
- result = TclpRealloc(ptr, size);
+ char *result = (char *) TclpRealloc(ptr, size);
if ((result == NULL) && size) {
Tcl_Panic("unable to realloc %u bytes", size);
@@ -1157,9 +1149,7 @@ Tcl_DbCkrealloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpRealloc(ptr, size);
+ char *result = (char *) TclpRealloc(ptr, size);
if ((result == NULL) && size) {
fflush(stdout);
@@ -1184,10 +1174,7 @@ Tcl_AttemptRealloc(
char *ptr,
unsigned int size)
{
- char *result;
-
- result = TclpRealloc(ptr, size);
- return result;
+ return (char *) TclpRealloc(ptr, size);
}
char *
@@ -1197,10 +1184,7 @@ Tcl_AttemptDbCkrealloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpRealloc(ptr, size);
- return result;
+ return (char *) TclpRealloc(ptr, size);
}
/*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 0f7f20a..bb5fa42 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1861,16 +1861,13 @@ StringMapCmd(
}
if (objc == 4) {
- const char *string = TclGetStringFromObj(objv[1], &length2);
+ static const char *opt[] = { "-nocase", NULL };
+ int idx;
- if ((length2 > 1) &&
- strncmp(string, "-nocase", (size_t) length2) == 0) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], opt, "option",
+ TCL_MULTIPLE_CHARS, &idx) == TCL_OK) {
nocase = 1;
} else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad option \"%s\": must be -nocase", string));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string, NULL);
return TCL_ERROR;
}
}
@@ -2127,17 +2124,13 @@ StringMatchCmd(
}
if (objc == 4) {
- int length;
- const char *string = TclGetStringFromObj(objv[1], &length);
+ static const char *opt[] = { "-nocase", NULL };
+ int idx;
- if ((length > 1) &&
- strncmp(string, "-nocase", (size_t) length) == 0) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], opt, "option",
+ TCL_MULTIPLE_CHARS, &idx) == TCL_OK) {
nocase = TCL_MATCH_NOCASE;
} else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad option \"%s\": must be -nocase", string));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string, NULL);
return TCL_ERROR;
}
}
@@ -2573,6 +2566,8 @@ StringEqualCmd(
int length1, length2, i, match, length, nocase = 0, reqlength = -1;
typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
strCmpFn_t strCmpFn;
+ static const char *opts[] = { "-length", "-nocase", NULL };
+ enum opts { OPT_LENGTH, OPT_NOCASE };
if (objc < 3 || objc > 6) {
str_cmp_args:
@@ -2582,25 +2577,24 @@ StringEqualCmd(
}
for (i = 1; i < objc-2; i++) {
- string2 = TclGetStringFromObj(objv[i], &length2);
- if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {
+ int idx;
+
+ if (Tcl_GetIndexFromObj(interp, objv[i], opts, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum opts) idx) {
+ case OPT_NOCASE:
nocase = 1;
- } else if ((length2 > 1)
- && !strncmp(string2, "-length", (size_t)length2)) {
- if (i+1 >= objc-2) {
+ break;
+ case OPT_LENGTH:
+ if (i >= objc-3) {
goto str_cmp_args;
}
- i++;
- if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[++i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
- } else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad option \"%s\": must be -nocase or -length",
- string2));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string2, NULL);
- return TCL_ERROR;
+ break;
}
}
@@ -2723,6 +2717,8 @@ StringCmpCmd(
int length1, length2, i, match, length, nocase = 0, reqlength = -1;
typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
strCmpFn_t strCmpFn;
+ static const char *opts[] = { "-length", "-nocase", NULL };
+ enum opts { OPT_LENGTH, OPT_NOCASE };
if (objc < 3 || objc > 6) {
str_cmp_args:
@@ -2732,25 +2728,24 @@ StringCmpCmd(
}
for (i = 1; i < objc-2; i++) {
- string2 = TclGetStringFromObj(objv[i], &length2);
- if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) {
+ int idx;
+
+ if (Tcl_GetIndexFromObj(interp, objv[i], opts, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum opts) idx) {
+ case OPT_NOCASE:
nocase = 1;
- } else if ((length2 > 1)
- && !strncmp(string2, "-length", (size_t)length2)) {
- if (i+1 >= objc-2) {
+ break;
+ case OPT_LENGTH:
+ if (i >= objc-3) {
goto str_cmp_args;
}
- i++;
- if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
+ if (TclGetIntFromObj(interp, objv[++i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
- } else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad option \"%s\": must be -nocase or -length",
- string2));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string2, NULL);
- return TCL_ERROR;
+ break;
}
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 6add83f..f0da2e8 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -7324,7 +7324,7 @@ Tcl_GetChannelBufferSize(
* An error message is generated in interp's result object to indicate
* that a command was invoked with the a bad option. The message has the
* form:
- * bad option "blah": should be one of
+ * bad/ambiguous option "blah": should be one of
* <...generic options...>+<...specific options...>
* "blah" is the optionName argument and "<specific options>" is a space
* separated list of specific option words. The function takes good care
@@ -7361,7 +7361,9 @@ Tcl_BadChannelOption(
Tcl_Panic("malformed option list in channel driver");
}
Tcl_ResetResult(interp);
- errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ",
+ // FIXME
+ errObj = Tcl_ObjPrintf(
+ "unknown or ambiguous option \"%s\": should be one of ",
optionName);
argc--;
for (i = 0; i < argc; i++) {
@@ -7700,6 +7702,7 @@ Tcl_SetChannelOption(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -buffering: must be one of"
" full, line, or none", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERING", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -7760,6 +7763,7 @@ Tcl_SetChannelOption(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
" character", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "EOFCHAR", NULL);
}
ckfree(argv);
return TCL_ERROR;
@@ -7775,6 +7779,7 @@ Tcl_SetChannelOption(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: should be a list of zero,"
" one, or two elements", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "EOFCHAR", NULL);
}
ckfree(argv);
return TCL_ERROR;
@@ -7809,6 +7814,7 @@ Tcl_SetChannelOption(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
" element list", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "TRANSLATION", NULL);
}
ckfree(argv);
return TCL_ERROR;
@@ -7835,13 +7841,7 @@ Tcl_SetChannelOption(
} else if (strcmp(readMode, "platform") == 0) {
translation = TCL_PLATFORM_TRANSLATION;
} else {
- if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "bad value for -translation: must be one of "
- "auto, binary, cr, lf, crlf, or platform", -1));
- }
- ckfree(argv);
- return TCL_ERROR;
+ goto badTranslation;
}
/*
@@ -7885,17 +7885,20 @@ Tcl_SetChannelOption(
} else if (strcmp(writeMode, "platform") == 0) {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
- if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "bad value for -translation: must be one of "
- "auto, binary, cr, lf, crlf, or platform", -1));
- }
- ckfree(argv);
- return TCL_ERROR;
+ goto badTranslation;
}
}
ckfree(argv);
return TCL_OK;
+ badTranslation:
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad value for -translation: must be one of "
+ "auto, binary, cr, lf, crlf, or platform", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "TRANSLATION", NULL);
+ }
+ ckfree(argv);
+ return TCL_ERROR;
} else if (chanPtr->typePtr->setOptionProc != NULL) {
return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
optionName, newValue);
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 3368a76..bcd9307 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -1660,8 +1660,8 @@ Tcl_FcopyObjCmd(
int mode, i, index;
Tcl_WideInt toRead;
Tcl_Obj *cmdPtr;
- static const char *const switches[] = { "-size", "-command", NULL };
- enum { FcopySize, FcopyCommand };
+ static const char *const switches[] = { "-command", "-size", NULL };
+ enum { FcopyCommand, FcopySize };
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
Tcl_WrongNumArgs(interp, 1, objv,
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index ce8b9fb..4697129 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -329,7 +329,8 @@ Tcl_GetIndexFromObjStruct(
* Check if we were instructed to disallow abbreviations.
*/
- if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
+ if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)
+ || ((flags & TCL_MULTIPLE_CHARS) && (p1 - key == 1))) {
goto error;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9a2e8dd..50d30f1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2653,6 +2653,14 @@ typedef struct ProcessGlobalValue {
#define TCL_NUMBER_NAN 5
/*
+ *----------------------------------------------------------------------
+ * Non-public flags for Tcl_GetIndexFromObj
+ *----------------------------------------------------------------------
+ */
+
+#define TCL_MULTIPLE_CHARS 2
+
+/*
*----------------------------------------------------------------
* Variables shared among Tcl modules but not used by the outside world.
*----------------------------------------------------------------
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index c10986a..e1012b4 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -830,7 +830,7 @@ Tcl_AfterObjCmd(
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad argument \"%s\": must be"
+ "unknown or ambiguous argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 8d35ec7..9b2bbad 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -171,6 +171,9 @@ test iocmd-5.3 {seek command} -returnCodes error -body {
test iocmd-5.4 {seek command} -returnCodes error -body {
seek stdin 100 gugu
} -result {bad origin "gugu": must be start, current, or end}
+test iocmd-5.5 {seek command} -returnCodes error -body {
+ seek stdin 100 ""
+} -result {ambiguous origin "": must be start, current, or end}
test iocmd-6.1 {tell command} {
list [catch {tell} msg] $msg
@@ -198,6 +201,13 @@ test iocmd-7.4 {close command} -setup {
} -cleanup {
close $chan
} -returnCodes error -result "bad direction \"bar\": must be read or write"
+test iocmd-7.4a {close command} -setup {
+ set chan [open [info script] r]
+} -body {
+ chan close $chan ""
+} -cleanup {
+ close $chan
+} -returnCodes error -result "ambiguous direction \"\": must be read or write"
test iocmd-7.5 {close command} -setup {
set chan [open [info script] r]
} -body {
@@ -221,7 +231,7 @@ test iocmd-8.4 {fconfigure command} {
set x [list [catch {fconfigure $f1 froboz} msg] $msg]
close $f1
set x
-} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+} {1 {unknown or ambiguous option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.5 {fconfigure command} {
list [catch {fconfigure stdin -buffering froboz} msg] $msg
} {1 {bad value for -buffering: must be one of full, line, or none}}
@@ -265,19 +275,19 @@ test iocmd-8.11 {fconfigure command} {
set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
close $chan
set res
-} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+} {1 {unknown or ambiguous option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.12 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -b blarfo} msg] $msg]
close $chan
set res
-} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+} {1 {unknown or ambiguous option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.13 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg]
close $chan
set res
-} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+} {1 {unknown or ambiguous option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
@@ -294,7 +304,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr
close $srv
unset cli srv port
rename iocmdSRV {}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname}
+} -returnCodes error -result {unknown or ambiguous option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname}
test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
@@ -337,7 +347,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl
if {$tty ne ""} {
close $tty
}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode}
+} -returnCodes error -result {unknown or ambiguous option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode}
test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup {
set tty ""
} -body {
@@ -348,7 +358,7 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable
if {$tty ne ""} {
close $tty
}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
+} -returnCodes error -result {unknown or ambiguous option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
# TODO: Test parsing of serial channel options (nonportable, since requires an
# open channel to work with).
@@ -639,7 +649,10 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile foo bar} msg] $msg
-} {1 {bad option "foo": must be -size or -command}}
+} {1 {bad option "foo": must be -command or -size}}
+test iocmd-15.10a {Tcl_FcopyObjCmd} {fcopy} {
+ list [catch {fcopy $rfile $wfile - bar} msg] $msg
+} {1 {ambiguous option "-": must be -command or -size}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
diff --git a/tests/string.test b/tests/string.test
index a8a83d9..f742094 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -40,7 +40,7 @@ test string-2.1 {string compare, too few args} {
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test string-2.2 {string compare, bad args} {
list [catch {string compare a b c} msg] $msg
-} {1 {bad option "a": must be -nocase or -length}}
+} {1 {bad option "a": must be -length or -nocase}}
test string-2.3 {string compare, bad args} {
list [catch {string compare -length -nocase str1 str2} msg] $msg
} {1 {expected integer but got "-nocase"}}
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 165ef20..d32f948 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -71,7 +71,7 @@ foreach {tname tbody tresult tcode} {
} {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
{bad args} {
string compare a b c
- } {bad option "a": must be -nocase or -length} {error}
+ } {bad option "a": must be -length or -nocase} {error}
{bad args} {
string compare -length -nocase str1 str2
} {expected integer but got "-nocase"} {error}
diff --git a/tests/timer.test b/tests/timer.test
index ab6efc9..e252eff 100644
--- a/tests/timer.test
+++ b/tests/timer.test
@@ -189,10 +189,10 @@ test timer-6.1 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
} -result {wrong # args: should be "after option ?arg ...?"}
test timer-6.2 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
after 2x
-} -result {bad argument "2x": must be cancel, idle, info, or an integer}
+} -result {unknown or ambiguous argument "2x": must be cancel, idle, info, or an integer}
test timer-6.3 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
after gorp
-} -result {bad argument "gorp": must be cancel, idle, info, or an integer}
+} -result {unknown or ambiguous argument "gorp": must be cancel, idle, info, or an integer}
test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
set x before
after 400 {set x after}
generated by cgit v0.12 at 2024-08-19 13:11:32 (GMT)