Patch for [TIP 56], [Bug: 219384] and [Bug: 455151]: deprecate the use

of Tcl_EvalTokens, replaced by the new Tcl_EvalTokensStandard.

8 files changed, 166 insertions, 67 deletions

diff --git a/ChangeLog b/ChangeLog
index 40053d0..bb29e41 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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