From aba59c2bf7de72267f36362e81a8be60872a5b9f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 23 Jun 2014 08:41:51 +0000 Subject: cleaning up option processing throughout Tcl to use common functions/language --- generic/tclCkalloc.c | 196 +++++++++++++++++++++++--------------------------- generic/tclCmdMZ.c | 81 ++++++++++----------- generic/tclIO.c | 35 ++++----- generic/tclIOCmd.c | 4 +- generic/tclIndexObj.c | 3 +- generic/tclInt.h | 8 +++ generic/tclTimer.c | 2 +- tests/ioCmd.test | 29 +++++--- tests/string.test | 2 +- tests/stringComp.test | 2 +- tests/timer.test | 4 +- 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 "" 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} -- cgit v0.12