diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclTest.c | 45 | ||||
| -rw-r--r-- | generic/tclVar.c | 9 |
2 files changed, 48 insertions, 6 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 diff --git a/generic/tclVar.c b/generic/tclVar.c index e6bff11..8478394 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.69.2.5 2004/05/22 17:01:39 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.69.2.6 2004/08/16 14:18:26 msofer Exp $ */ #include "tclInt.h" @@ -1562,7 +1562,7 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr; /* New value for variable. */ - CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * and TCL_LEAVE_ERR_MSG bits. */ { Interp *iPtr = (Interp *) interp; @@ -1621,8 +1621,11 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) * "copy on write". */ + if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) { + TclSetVarUndefined(varPtr); + } oldValuePtr = varPtr->value.objPtr; - if (flags & TCL_APPEND_VALUE) { + if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { Tcl_DecrRefCount(oldValuePtr); /* discard old value */ varPtr->value.objPtr = NULL; |