diff options
| -rw-r--r-- | ChangeLog | 15 | ||||
| -rw-r--r-- | doc/ParseCmd.3 | 43 | ||||
| -rw-r--r-- | generic/tcl.decls | 8 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 14 | ||||
| -rw-r--r-- | generic/tclDecls.h | 11 | ||||
| -rw-r--r-- | generic/tclParse.c | 133 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 3 | ||||
| -rw-r--r-- | tests/parse.test | 6 |
8 files changed, 166 insertions, 67 deletions
@@ -1,3 +1,18 @@ +2001-08-28 Miguel Sofer <msofer@users.sourceforge.net> + + * doc/ParseCmd.3: + * generic/tcl.decls: + * generic/tclCmdMZ.c (Tcl_SubstObjCmd): + * generic/tclDecls.h: + * generic/tclParse.c: + * generic/tclStubInit.c: + * tests/parse.test: Deprecate the use of Tcl_EvalTokens, replaced + by the new Tcl_EvalTokensStandard. The new function performs the + same duties but adheres to the standard return convention for Tcl + evaluations; the deprecated function could only return TCL_OK or + TCL_ERROR, which caused [Bug: 219384] and [Bug: 455151]. + + 2001-09-12 Mo DeJong <mdejong@users.sourceforge.net> * unix/configure: Regen. diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index 4e9e81b..6e23c21 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -4,13 +4,15 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ParseCmd.3,v 1.4 2000/04/24 23:53:03 ericm Exp $ +'\" RCS: @(#) $Id: ParseCmd.3,v 1.5 2001/09/13 11:56:19 msofer Exp $ '\" .so man.macros .TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens \- parse Tcl scripts and expressions +Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, +Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, +Tcl_EvalTokens, BTcl_EvalTokensStandard \- parse Tcl scripts and expressions .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -37,13 +39,17 @@ char * .sp Tcl_Obj * \fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) +.sp +Tcl_Obj * +\fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr .AP Tcl_Interp *interp out -For procedures other than \fBTcl_FreeParse\fR and \fBTcl_EvalTokens\fR, -used only for error reporting; +For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR +and \fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. -For \fBTcl_EvalTokens\fR, determines the context for evaluating the +For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, +determines the context for evaluating the script and also is used for error reporting; must not be NULL. .AP char *string in Pointer to first character in string to parse. @@ -178,18 +184,27 @@ These procedures ignore any existing information in so if repeated calls are being made to any of them then \fBTcl_FreeParse\fR must be invoked once after each call. .PP -\fBTcl_EvalTokens\fR evaluates a sequence of parse tokens from a Tcl_Parse -structure. The tokens typically consist +\fBTcl_EvalTokensStandard\fR evaluates a sequence of parse tokens from +a Tcl_Parse structure. The tokens typically consist of all the tokens in a word or all the tokens that make up the index for -a reference to an array variable. \fBTcl_EvalTokens\fR performs the -substitutions requested by the tokens, concatenates the -resulting values, and returns the result in a new Tcl_Obj. The -reference count of the object returned as result has been +a reference to an array variable. \fBTcl_EvalTokensStandard\fR performs the +substitutions requested by the tokens and concatenates the +resulting values. +The return value from \fBTcl_EvalTokensStandard\fR is a Tcl completion +code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, +\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. +In addition, a result value or error message is left in \fIinterp\fR's +result; it can be retrieved using \fBTcl_GetObjResult\fR. +.PP +\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in +the return convention used: it returns the result in a new Tcl_Obj. +The reference count of the object returned as result has been incremented, so the caller must invoke \fBTcl_DecrRefCount\fR when it is finished with the object. -If an error occurs while evaluating the tokens (such as a reference to -a non-existent variable) then the return value is NULL and an error -message is left in \fIinterp\fR's result. +If an error or other exception occurs while evaluating the tokens +(such as a reference to a non-existent variable) then the return value +is NULL and an error message is left in \fIinterp\fR's result. The use +of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP diff --git a/generic/tcl.decls b/generic/tcl.decls index 486c9e2..b53bdad 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.57 2001/09/12 16:32:21 msofer Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.58 2001/09/13 11:56:19 msofer Exp $ library tcl @@ -1682,9 +1682,9 @@ declare 480 generic { void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr) } # New function due to TIP#56 -#declare 481 generic { -# int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) -#} +declare 481 generic { + int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) +} ############################################################################## diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2d1446b..108d931 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.43 2001/08/07 00:56:15 hobbs Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.44 2001/09/13 11:56:19 msofer Exp $ */ #include "tclInt.h" @@ -2371,7 +2371,7 @@ Tcl_SubstObj(interp, objPtr, flags) case '$': if (flags & TCL_SUBST_VARIABLES) { Tcl_Parse parse; - Tcl_Obj *tempObj; + int code; /* * Code is simpler overall if we (effectively) inline @@ -2398,13 +2398,13 @@ Tcl_SubstObj(interp, objPtr, flags) Tcl_AppendToObj(resultObj, old, p-old); } p += parse.tokenPtr->size; - tempObj = Tcl_EvalTokens(interp, parse.tokenPtr, - parse.numTokens); - if (tempObj == NULL) { + code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, + parse.numTokens); + if (code != TCL_OK) { goto errorResult; } - Tcl_AppendObjToObj(resultObj, tempObj); - Tcl_DecrRefCount(tempObj); + Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); + Tcl_ResetResult(interp); old = p; } else { p++; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ca2d0f1..9670564 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -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: tclDecls.h,v 1.57 2001/09/06 17:51:00 vincentdarley Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.58 2001/09/13 11:56:19 msofer Exp $ */ #ifndef _TCLDECLS @@ -1500,6 +1500,10 @@ EXTERN int Tcl_OutputBuffered _ANSI_ARGS_((Tcl_Channel chan)); /* 480 */ EXTERN void Tcl_FSMountsChanged _ANSI_ARGS_(( Tcl_Filesystem * fsPtr)); +/* 481 */ +EXTERN int Tcl_EvalTokensStandard _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Token * tokenPtr, + int count)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -2040,6 +2044,7 @@ typedef struct TclStubs { Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */ int (*tcl_OutputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 479 */ void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */ + int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */ } TclStubs; #ifdef __cplusplus @@ -4004,6 +4009,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_FSMountsChanged \ (tclStubsPtr->tcl_FSMountsChanged) /* 480 */ #endif +#ifndef Tcl_EvalTokensStandard +#define Tcl_EvalTokensStandard \ + (tclStubsPtr->tcl_EvalTokensStandard) /* 481 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclParse.c b/generic/tclParse.c index de62df8..a6eaab3 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.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: tclParse.c,v 1.15 2001/05/03 21:14:57 msofer Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.16 2001/09/13 11:56:20 msofer Exp $ */ #include "tclInt.h" @@ -1117,28 +1117,26 @@ Tcl_LogCommandInfo(interp, script, command, length) /* *---------------------------------------------------------------------- * - * Tcl_EvalTokens -- + * Tcl_EvalTokensStandard -- * * Given an array of tokens parsed from a Tcl command (e.g., the * tokens that make up a word or the index for an array variable) * this procedure evaluates the tokens and concatenates their * values to form a single result value. - * + * * Results: - * The return value is a pointer to a newly allocated Tcl_Obj - * containing the value of the array of tokens. The reference - * count of the returned object has been incremented. If an error - * occurs in evaluating the tokens then a NULL value is returned - * and an error message is left in interp's result. + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. * * Side effects: - * A new object is allocated to hold the result. - * + * Depends on the array of tokens being evaled. + * *---------------------------------------------------------------------- */ -Tcl_Obj * -Tcl_EvalTokens(interp, tokenPtr, count) +int +Tcl_EvalTokensStandard(interp, tokenPtr, count) Tcl_Interp *interp; /* Interpreter in which to lookup * variables, execute nested commands, * and report errors. */ @@ -1166,7 +1164,9 @@ Tcl_EvalTokens(interp, tokenPtr, count) * command's result object directly. */ + code = TCL_OK; resultPtr = NULL; + Tcl_ResetResult(interp); for ( ; count > 0; count--, tokenPtr++) { valuePtr = NULL; @@ -1192,7 +1192,7 @@ Tcl_EvalTokens(interp, tokenPtr, count) code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, 0); if (code != TCL_OK) { - goto error; + goto done; } valuePtr = Tcl_GetObjResult(interp); break; @@ -1200,12 +1200,16 @@ Tcl_EvalTokens(interp, tokenPtr, count) case TCL_TOKEN_VARIABLE: if (tokenPtr->numComponents == 1) { indexPtr = NULL; + index = NULL; } else { - indexPtr = Tcl_EvalTokens(interp, tokenPtr+2, + code = Tcl_EvalTokensStandard(interp, tokenPtr+2, tokenPtr->numComponents - 1); - if (indexPtr == NULL) { - goto error; + if (code != TCL_OK) { + goto done; } + indexPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(indexPtr); + index = Tcl_GetString(indexPtr); } /* @@ -1223,11 +1227,6 @@ Tcl_EvalTokens(interp, tokenPtr, count) } strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); varName[tokenPtr[1].size] = 0; - if (indexPtr != NULL) { - index = TclGetString(indexPtr); - } else { - index = NULL; - } valuePtr = Tcl_GetVar2Ex(interp, varName, index, TCL_LEAVE_ERR_MSG); if (varName != nameBuffer) { @@ -1237,14 +1236,15 @@ Tcl_EvalTokens(interp, tokenPtr, count) Tcl_DecrRefCount(indexPtr); } if (valuePtr == NULL) { - goto error; + code = TCL_ERROR; + goto done; } count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; default: - panic("unexpected token type in Tcl_EvalTokens"); + panic("unexpected token type in Tcl_EvalTokensStandard"); } /* @@ -1272,14 +1272,69 @@ Tcl_EvalTokens(interp, tokenPtr, count) Tcl_AppendToObj(resultPtr, p, length); } } - return resultPtr; - - error: if (resultPtr != NULL) { + Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); + } else { + code = TCL_ERROR; + } + + done: + return code; +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalTokens -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the + * tokens that make up a word or the index for an array variable) + * this procedure evaluates the tokens and concatenates their + * values to form a single result value. + * + * Results: + * The return value is a pointer to a newly allocated Tcl_Obj + * containing the value of the array of tokens. The reference + * count of the returned object has been incremented. If an error + * occurs in evaluating the tokens then a NULL value is returned + * and an error message is left in interp's result. + * + * Side effects: + * A new object is allocated to hold the result. + * + *---------------------------------------------------------------------- + * + * This uses a non-standard return convention; its use is now deprecated. + * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not + * used in the core any longer. It is only kept for backward compatibility. + */ + +Tcl_Obj * +Tcl_EvalTokens(interp, tokenPtr, count) + Tcl_Interp *interp; /* Interpreter in which to lookup + * variables, execute nested commands, + * and report errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to evaluate and concatenate. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + int code; + Tcl_Obj *resPtr; + + code = Tcl_EvalTokensStandard(interp, tokenPtr, count); + if (code == TCL_OK) { + resPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resPtr); + Tcl_ResetResult(interp); + return resPtr; + } else { + return NULL; } - return NULL; } + /* *---------------------------------------------------------------------- @@ -1378,10 +1433,12 @@ Tcl_EvalEx(interp, script, numBytes, flags) for (objectsUsed = 0, tokenPtr = parse.tokenPtr; objectsUsed < parse.numWords; objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { - objv[objectsUsed] = Tcl_EvalTokens(interp, tokenPtr+1, - tokenPtr->numComponents); - if (objv[objectsUsed] == NULL) { - code = TCL_ERROR; + code = Tcl_EvalTokensStandard(interp, tokenPtr+1, + tokenPtr->numComponents); + if (code == TCL_OK) { + objv[objectsUsed] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objectsUsed]); + } else { goto error; } } @@ -1841,6 +1898,7 @@ Tcl_ParseVar(interp, string, termPtr) { Tcl_Parse parse; register Tcl_Obj *objPtr; + int code; if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) { return NULL; @@ -1857,22 +1915,19 @@ Tcl_ParseVar(interp, string, termPtr) return "$"; } - objPtr = Tcl_EvalTokens(interp, parse.tokenPtr, parse.numTokens); - if (objPtr == NULL) { + code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens); + if (code != TCL_OK) { return NULL; } + objPtr = Tcl_GetObjResult(interp); /* * At this point we should have an object containing the value of * a variable. Just return the string from that object. */ -#ifdef TCL_COMPILE_DEBUG - if (objPtr->refCount < 2) { - panic("Tcl_ParseVar got temporary object from Tcl_EvalTokens"); - } -#endif /*TCL_COMPILE_DEBUG*/ - TclDecrRefCount(objPtr); + Tcl_IncrRefCount(objPtr); + Tcl_ResetResult(interp); return TclGetString(objPtr); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 900979a..2a1fbfb 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -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: tclStubInit.c,v 1.60 2001/09/10 17:17:41 andreas_kupries Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.61 2001/09/13 11:56:20 msofer Exp $ */ #include "tclInt.h" @@ -878,6 +878,7 @@ TclStubs tclStubs = { Tcl_FSGetPathType, /* 478 */ Tcl_OutputBuffered, /* 479 */ Tcl_FSMountsChanged, /* 480 */ + Tcl_EvalTokensStandard, /* 481 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/parse.test b/tests/parse.test index a253a48..472e5d4 100644 --- a/tests/parse.test +++ b/tests/parse.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: parse.test,v 1.7 2000/04/10 17:19:02 ericm Exp $ +# RCS: @(#) $Id: parse.test,v 1.8 2001/09/13 11:56:20 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -732,6 +732,10 @@ test parse-16.1 {Tcl_EvalEx, check termOffset is set correctly for non TCL_OK ca subst {[eval {return foo}]bar} } foobar +test parse-17.1 {Correct return codes from errors during substitution} { + catch {eval {w[continue]}} +} 4 + # cleanup catch {unset a} ::tcltest::cleanupTests |