summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2001-09-13 11:56:19 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2001-09-13 11:56:19 (GMT)
commitd819427fc86d39d465f72f010f19054c74c625ca (patch)
tree312894adaa8a1fb3ac1306ff74033406cbf3f8fd
parent8fb82585043253ad71e5623478fda7d8a67b1c23 (diff)
downloadtcl-d819427fc86d39d465f72f010f19054c74c625ca.zip
tcl-d819427fc86d39d465f72f010f19054c74c625ca.tar.gz
tcl-d819427fc86d39d465f72f010f19054c74c625ca.tar.bz2
Patch for [TIP 56], [Bug: 219384] and [Bug: 455151]: deprecate the use
of Tcl_EvalTokens, replaced by the new Tcl_EvalTokensStandard.
-rw-r--r--ChangeLog15
-rw-r--r--doc/ParseCmd.343
-rw-r--r--generic/tcl.decls8
-rw-r--r--generic/tclCmdMZ.c14
-rw-r--r--generic/tclDecls.h11
-rw-r--r--generic/tclParse.c133
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--tests/parse.test6
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