diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | doc/SetVar.3 | 5 | ||||
| -rw-r--r-- | generic/tclTest.c | 45 | ||||
| -rw-r--r-- | generic/tclVar.c | 9 | ||||
| -rw-r--r-- | tests/result.test | 33 |
5 files changed, 89 insertions, 13 deletions
@@ -1,4 +1,12 @@ -2004-03-31 Don Porter <dgp@users.sourceforge.net> +2004-07-23 Miguel Sofer <msofer@users.sf.net> + + * doc/SetVar.3: + * generic/tclTest.c (TestseterrorcodeCmd): + * generic/tclVar.c (TclPtrSetVar): + * tests/result.test (result-4.*, result-5.*): [Bug 1008314] + detected and fixed by dgp. + +2004-08-13 Don Porter <dgp@users.sourceforge.net> * library/msgcat/msgcat.tcl: Added checks to prevent [mclocale] * tests/msgcat.test: from registering filesystem paths to possibly diff --git a/doc/SetVar.3 b/doc/SetVar.3 index 90b140b..c18c4c1 100644 --- a/doc/SetVar.3 +++ b/doc/SetVar.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: SetVar.3,v 1.8 2003/07/18 16:56:41 dgp Exp $ +'\" RCS: @(#) $Id: SetVar.3,v 1.9 2004/08/16 14:11:16 msofer Exp $ '\" .so man.macros .TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures" @@ -221,6 +221,9 @@ A separator space is appended before the new list element unless the list element is going to be the first element in a list or sublist (i.e. the variable's current value is empty, or contains the single character ``{'', or ends in `` }''). +When appending, the original value of the variable must also be +a valid list, so that the operation is the appending of a new +list element onto a list. .PP \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR return the current value of a variable. diff --git a/generic/tclTest.c b/generic/tclTest.c index fc0356f..96d18d9 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.82 2004/05/19 10:38:24 dkf Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.83 2004/08/16 14:11:16 msofer Exp $ */ #define TCL_TEST @@ -319,6 +319,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[])); @@ -670,6 +672,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); @@ -3890,11 +3894,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 4b69ce6..6c1a4e5 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.87 2004/07/23 18:32:06 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.88 2004/08/16 14:11:31 msofer Exp $ */ #ifdef STDC_HEADERS @@ -1566,7 +1566,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; @@ -1625,8 +1625,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; diff --git a/tests/result.test b/tests/result.test index 8054b75..92f8d41 100644 --- a/tests/result.test +++ b/tests/result.test @@ -65,27 +65,50 @@ test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} { testsaveresult free {set x 42} 1 } {42} -test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsaveresult} { +::tcltest::testConstraint testsetobjerrorcode \ + [expr {[info commands testsetobjerrorcode] != {}}] + +test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsetobjerrorcode} { catch {testsetobjerrorcode 1} list [set errorCode] } {1} -test result-4.2 {Tcl_SetObjErrorCode - two args} {testsaveresult} { +test result-4.2 {Tcl_SetObjErrorCode - two args} {testsetobjerrorcode} { catch {testsetobjerrorcode 1 2} list [set errorCode] } {{1 2}} -test result-4.3 {Tcl_SetObjErrorCode - three args} {testsaveresult} { +test result-4.3 {Tcl_SetObjErrorCode - three args} {testsetobjerrorcode} { catch {testsetobjerrorcode 1 2 3} list [set errorCode] } {{1 2 3}} -test result-4.4 {Tcl_SetObjErrorCode - four args} {testsaveresult} { +test result-4.4 {Tcl_SetObjErrorCode - four args} {testsetobjerrorcode} { catch {testsetobjerrorcode 1 2 3 4} list [set errorCode] } {{1 2 3 4}} -test result-4.5 {Tcl_SetObjErrorCode - five args} {testsaveresult} { +test result-4.5 {Tcl_SetObjErrorCode - five args} {testsetobjerrorcode} { catch {testsetobjerrorcode 1 2 3 4 5} list [set errorCode] } {{1 2 3 4 5}} +::tcltest::testConstraint testseterrorcode \ + [expr {[info commands testseterrorcode] != {}}] + +test result-5.1 {Tcl_SetErrorCode - one arg} testseterrorcode { + catch {testseterrorcode 1} + set errorCode +} 1 +test result-5.2 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode { + catch {testseterrorcode {a b}} + set errorCode +} {{a b}} +test result-5.3 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode { + catch {testseterrorcode \{} + llength $errorCode +} 1 +test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode { + catch {testseterrorcode {a b} c} + set errorCode +} {{a b} c} + # cleanup ::tcltest::cleanupTests return |