diff options
Diffstat (limited to 'generic/tclTest.c')
| -rw-r--r-- | generic/tclTest.c | 45 |
1 files changed, 42 insertions, 3 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index 1d7774a..dbd2b8e 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,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.62.2.8 2004/06/08 20:25:43 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.62.2.9 2004/08/16 14:18:25 msofer Exp $ */ #define TCL_TEST @@ -315,6 +315,8 @@ static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -654,6 +656,8 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testseterr", TestsetCmd, (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); @@ -3811,11 +3815,46 @@ TestupvarCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestseterrorcodeCmd -- + * + * This procedure implements the "testseterrorcodeCmd". + * This tests up to five elements passed to the + * Tcl_SetErrorCode command. + * + * Results: + * A standard Tcl result. Always returns TCL_ERROR so that + * the error code can be tested. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestseterrorcodeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + CONST char **argv; /* Argument strings. */ +{ + if (argc > 6) { + Tcl_SetResult(interp, "too many args", TCL_STATIC); + return TCL_ERROR; + } + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TestsetobjerrorcodeCmd -- * * This procedure implements the "testsetobjerrorcodeCmd". - * This tests up to five elements passed to the - * Tcl_SetObjErrorCode command. + * This tests the Tcl_SetObjErrorCode function. * * Results: * A standard Tcl result. Always returns TCL_ERROR so that |