Attachment "patch455151.txt" to
ticket [455151ffff]
added by
msofer
2001-09-13 01:21:47.
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.603
diff -u -r1.603 ChangeLog
--- ChangeLog 2001/09/12 16:32:21 1.603
+++ ChangeLog 2001/09/12 18:14:05
@@ -1,3 +1,17 @@
+2001-08-28 Miguel Sofer <[email protected]>
+
+ * 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 Miguel Sofer <[email protected]>
* generic/tcl.decls: reserved stub #481 for the implementation of
Index: doc/ParseCmd.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/ParseCmd.3,v
retrieving revision 1.4
diff -u -r1.4 ParseCmd.3
--- doc/ParseCmd.3 2000/04/24 23:53:03 1.4
+++ doc/ParseCmd.3 2001/09/12 18:14:06
@@ -10,7 +10,9 @@
.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 @@
.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 @@
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
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.57
diff -u -r1.57 tcl.decls
--- generic/tcl.decls 2001/09/12 16:32:21 1.57
+++ generic/tcl.decls 2001/09/12 18:14:08
@@ -1682,9 +1682,9 @@
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)
+}
##############################################################################
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.43
diff -u -r1.43 tclCmdMZ.c
--- generic/tclCmdMZ.c 2001/08/07 00:56:15 1.43
+++ generic/tclCmdMZ.c 2001/09/12 18:14:10
@@ -2371,7 +2371,7 @@
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_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++;
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.57
diff -u -r1.57 tclDecls.h
--- generic/tclDecls.h 2001/09/06 17:51:00 1.57
+++ generic/tclDecls.h 2001/09/12 18:14:14
@@ -1500,6 +1500,10 @@
/* 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 @@
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
@@ -4003,6 +4008,10 @@
#ifndef Tcl_FSMountsChanged
#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) */
Index: generic/tclParse.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParse.c,v
retrieving revision 1.15
diff -u -r1.15 tclParse.c
--- generic/tclParse.c 2001/05/03 21:14:57 1.15
+++ generic/tclParse.c 2001/09/12 18:14:16
@@ -1117,28 +1117,26 @@
/*
*----------------------------------------------------------------------
*
- * 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 @@
* command's result object directly.
*/
+ code = TCL_OK;
resultPtr = NULL;
+ Tcl_ResetResult(interp);
for ( ; count > 0; count--, tokenPtr++) {
valuePtr = NULL;
@@ -1192,7 +1192,7 @@
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 @@
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 @@
}
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_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_AppendToObj(resultPtr, p, length);
}
}
- return resultPtr;
-
- error:
if (resultPtr != NULL) {
+ Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
+ } else {
+ code = TCL_ERROR;
}
- return NULL;
+
+ 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;
+ }
+}
+
/*
*----------------------------------------------------------------------
@@ -1378,10 +1433,12 @@
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_Parse parse;
register Tcl_Obj *objPtr;
+ int code;
if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) {
return NULL;
@@ -1857,22 +1915,19 @@
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);
}
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.60
diff -u -r1.60 tclStubInit.c
--- generic/tclStubInit.c 2001/09/10 17:17:41 1.60
+++ generic/tclStubInit.c 2001/09/12 18:14:17
@@ -878,6 +878,7 @@
Tcl_FSGetPathType, /* 478 */
Tcl_OutputBuffered, /* 479 */
Tcl_FSMountsChanged, /* 480 */
+ Tcl_EvalTokensStandard, /* 481 */
};
/* !END!: Do not edit above this line. */
Index: tests/parse.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/parse.test,v
retrieving revision 1.7
diff -u -r1.7 parse.test
--- tests/parse.test 2000/04/10 17:19:02 1.7
+++ tests/parse.test 2001/09/12 18:14:17
@@ -732,6 +732,10 @@
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
