diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 12 | ||||
| -rw-r--r-- | generic/tclTest.c | 64 | ||||
| -rw-r--r-- | tests/indexObj.test | 21 |
4 files changed, 104 insertions, 5 deletions
@@ -1,3 +1,15 @@ +2000-08-07 Eric Melski <ericm@ajubasolutions.com> + + * tests/indexObj.test: Added tests using the [testwrongnumargs] + command to test Tcl_WrongNumArgs. + + * generic/tclTest.c (TestWrongNumArgsObjCmd): Added test function + for the Tcl_WrongNumArgs function. + + * generic/tclIndexObj.c (Tcl_WrongNumArgs): Corrected algorithm to + not insert a space before the message component when objc == 0 + [Bug: 6078]. + 2000-07-27 Mo DeJong <mdejong@redhat.com> * win/configure.in: TCL_STUB_LIB_FLAG should not diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 7e60153..49bbe63 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.5 2000/06/06 19:34:34 hobbs Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.6 2000/08/07 22:42:31 ericm Exp $ */ #include "tclInt.h" @@ -334,12 +334,18 @@ Tcl_WrongNumArgs(interp, objc, objv, message) Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), (char *) NULL); } - if (i < (objc - 1)) { + + /* + * Append a space character (" ") if there is more text to follow + * (either another element from objv, or the message string). + */ + if ((i < (objc - 1)) || message) { Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); } } + if (message) { - Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL); + Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); } Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); } diff --git a/generic/tclTest.c b/generic/tclTest.c index 085d99c..6f90e20 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.19 2000/07/26 01:28:49 davidg Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.20 2000/08/07 22:42:31 ericm Exp $ */ #define TCL_TEST @@ -290,6 +290,10 @@ static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestWrongNumArgsObjCmd _ANSI_ARGS_(( + ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestChannelCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData, @@ -343,6 +347,8 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, @@ -4849,3 +4855,59 @@ TestChannelEventCmd(dummy, interp, argc, argv) "add, delete, list, set, or removeall", (char *) NULL); return TCL_ERROR; } + +/* + *---------------------------------------------------------------------- + * + * TestWrongNumArgsObjCmd -- + * + * Test the Tcl_WrongNumArgs function. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Sets interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +TestWrongNumArgsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int i, length; + char *msg; + + if (objc < 3) { + /* + * Don't use Tcl_WrongNumArgs here, as that is the function + * we want to test! + */ + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { + return TCL_ERROR; + } + + msg = Tcl_GetStringFromObj(objv[2], &length); + if (length == 0) { + msg = NULL; + } + + if (i > objc - 3) { + /* + * Asked for more arguments than were given. + */ + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + return TCL_ERROR; + } + + Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); + return TCL_OK; +} diff --git a/tests/indexObj.test b/tests/indexObj.test index 6a69a9d..4dd83f5 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: indexObj.test,v 1.5 2000/04/10 17:19:00 ericm Exp $ +# RCS: @(#) $Id: indexObj.test,v 1.6 2000/08/07 22:42:32 ericm Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -70,6 +70,25 @@ test indexObj-4.1 {free old internal representation} { testindexobj 1 1 $x abc def {a b} zzz } {2} +test indexObj-5.1 {Tcl_WrongNumArgs} { + testwrongnumargs 1 "?option?" mycmd +} "wrong # args: should be \"mycmd ?option?\"" +test indexObj-5.2 {Tcl_WrongNumArgs} { + testwrongnumargs 2 "bar" mycmd foo +} "wrong # args: should be \"mycmd foo bar\"" +test indexObj-5.3 {Tcl_WrongNumArgs} { + testwrongnumargs 0 "bar" mycmd foo +} "wrong # args: should be \"bar\"" +test indexObj-5.4 {Tcl_WrongNumArgs} { + testwrongnumargs 0 "" mycmd foo +} "wrong # args: should be \"\"" +test indexObj-5.5 {Tcl_WrongNumArgs} { + testwrongnumargs 1 "" mycmd foo +} "wrong # args: should be \"mycmd\"" +test indexObj-5.6 {Tcl_WrongNumArgs} { + testwrongnumargs 2 "" mycmd foo +} "wrong # args: should be \"mycmd foo\"" + # cleanup ::tcltest::cleanupTests return |