TIP#36 implementation. Also includes cleanup for subst option

handling and improved documentation for the subst command (in my
capacity as maintainer of the Commands M-Z functional area.)

5 files changed, 167 insertions, 76 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index f60a719..679cff8 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.49 2001/06/08 20:06:11 dgp Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.50 2001/07/12 13:15:09 dkf Exp $
 
 library tcl
 
@@ -1527,7 +1527,9 @@ declare 435 generic {
 declare 436 generic {
     Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, CONST char *pattern)
 }
-
+declare 437 generic {
+    Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
+}
 
 ##############################################################################
 
diff --git a/generic/tcl.h b/generic/tcl.h
index 3e8a71a..a08cbc8 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -12,7 +12,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.h,v 1.91 2001/06/08 20:06:11 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.92 2001/07/12 13:15:09 dkf Exp $
  */
 
 #ifndef _TCL
@@ -535,6 +535,15 @@ typedef struct stat *Tcl_Stat_;
 #define TCL_RESULT_SIZE 200
 
 /*
+ * Flags to control what substitutions are performed by Tcl_SubstObj():
+ */
+
+#define TCL_SUBST_COMMANDS	001
+#define TCL_SUBST_VARIABLES	002
+#define TCL_SUBST_BACKSLASHES	004
+#define TCL_SUBST_ALL		007
+
+/*
  * Argument descriptors for math function callbacks in expressions:
  */
 
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 5984ed0..1024430 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.39 2001/06/12 08:07:37 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.40 2001/07/12 13:15:09 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -2247,8 +2247,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
  *
  *	This procedure is invoked to process the "subst" Tcl command.
  *	See the user documentation for details on what it does.  This
- *	command is an almost direct copy of an implementation by
- *	Andrew Payne.
+ *	command relies on Tcl_SubstObj() for its implementation.
  *
  * Results:
  *	A standard Tcl result.
@@ -2273,21 +2272,15 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv)
     enum substOptions {
 	SUBST_NOBACKSLASHES,      SUBST_NOCOMMANDS,       SUBST_NOVARS
     };
-    Interp *iPtr = (Interp *) interp;
-    Tcl_DString result;
-    char *p, *old, *value;
-    int optionIndex, code, count, doVars, doCmds, doBackslashes, i;
+    Tcl_Obj *resultPtr;
+    int optionIndex, flags, i;
 
     /*
      * Parse command-line options.
      */
 
-    doVars = doCmds = doBackslashes = 1;
+    flags = TCL_SUBST_ALL;
     for (i = 1; i < (objc-1); i++) {
-	p = Tcl_GetString(objv[i]);
-	if (*p != '-') {
-	    break;
-	}
 	if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
 		"switch", 0, &optionIndex) != TCL_OK) {
 
@@ -2295,15 +2288,15 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv)
 	}
 	switch (optionIndex) {
 	    case SUBST_NOBACKSLASHES: {
-		doBackslashes = 0;
+		flags &= ~TCL_SUBST_BACKSLASHES;
 		break;
 	    }
 	    case SUBST_NOCOMMANDS: {
-		doCmds = 0;
+		flags &= ~TCL_SUBST_COMMANDS;
 		break;
 	    }
 	    case SUBST_NOVARS: {
-		doVars = 0;
+		flags &= ~TCL_SUBST_VARIABLES;
 		break;
 	    }
 	    default: {
@@ -2318,76 +2311,154 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv)
     }
 
     /*
-     * Scan through the string one character at a time, performing
-     * command, variable, and backslash substitutions.
+     * Perform the substitution.
      */
+    resultPtr = Tcl_SubstObj(interp, objv[i], flags);
 
-    Tcl_DStringInit(&result);
-    old = p = Tcl_GetString(objv[i]);
-    while (*p != 0) {
+    if (resultPtr == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, resultPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SubstObjCmd --
+ *
+ *	This function performs the substitutions specificed on the
+ *	given string as described in the user documentation for the
+ *	"subst" Tcl command.  This code is heavily based on an
+ *	implementation by Andrew Payne.  Note that if a command
+ *	substitution returns TCL_CONTINUE or TCL_RETURN from its
+ *	evaluation and is not completely well-formed, the results are
+ *	not defined.
+ *
+ * Results:
+ *	A Tcl_Obj* containing the substituted string, or NULL to
+ *	indicate that an error occurred.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_SubstObj(interp, objPtr, flags)
+    Tcl_Interp *interp;
+    Tcl_Obj *objPtr;
+    int flags;
+{
+    Tcl_Obj *resultObj;
+    char *p, *old;
+
+    old = p = Tcl_GetString(objPtr);
+    resultObj = Tcl_NewStringObj("", 0);
+    while (1) {
 	switch (*p) {
-	    case '\\':
-		if (doBackslashes) {
-		    char buf[TCL_UTF_MAX];
+	case 0:
+	    if (p != old) {
+		Tcl_AppendToObj(resultObj, old, p-old);
+	    }
+	    return resultObj;
 
-		    if (p != old) {
-			Tcl_DStringAppend(&result, old, p-old);
-		    }
-		    Tcl_DStringAppend(&result, buf,
-			    Tcl_UtfBackslash(p, &count, buf));
-		    p += count;
-		    old = p;
-		} else {
-		    p++;
+	case '\\':
+	    if (flags & TCL_SUBST_BACKSLASHES) {
+		char buf[TCL_UTF_MAX];
+		int count;
+
+		if (p != old) {
+		    Tcl_AppendToObj(resultObj, old, p-old);
 		}
-		break;
+		Tcl_AppendToObj(resultObj, buf,
+				Tcl_UtfBackslash(p, &count, buf));
+		p += count;
+		old = p;
+	    } else {
+		p++;
+	    }
+	    break;
 
-	    case '$':
-		if (doVars) {
-		    if (p != old) {
-			Tcl_DStringAppend(&result, old, p-old);
-		    }
-		    value = Tcl_ParseVar(interp, p, &p);
-		    if (value == NULL) {
-			Tcl_DStringFree(&result);
-			return TCL_ERROR;
-		    }
-		    Tcl_DStringAppend(&result, value, -1);
-		    old = p;
-		} else {
+	case '$':
+	    if (flags & TCL_SUBST_VARIABLES) {
+		Tcl_Parse parse;
+		Tcl_Obj *tempObj;
+
+		/*
+		 * Code is simpler overall if we (effectively) inline
+		 * Tcl_ParseVar, particularly as that allows us to use
+		 * a non-string interface when we come to appending
+		 * the variable contents to the result object.  There
+		 * are a few other optimisations that doing this
+		 * enables (like being able to continue the run of
+		 * unsubstituted characters straight through if a '$'
+		 * does not precede a variable name.)
+		 */
+		if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) {
+		    goto errorResult;
+		}
+		if (parse.numTokens == 1) {
+		    /*
+		     * There isn't a variable name after all: the $ is
+		     * just a $.
+		     */
 		    p++;
+		    break;
 		}
-		break;
+		if (p != old) {
+		    Tcl_AppendToObj(resultObj, old, p-old);
+		}
+		p += parse.tokenPtr->size;
+		tempObj = Tcl_EvalTokens(interp, parse.tokenPtr,
+					 parse.numTokens);
+		if (tempObj == NULL) {
+		    goto errorResult;
+		}
+		Tcl_AppendObjToObj(resultObj, tempObj);
+		Tcl_DecrRefCount(tempObj);
+		old = p;
+	    } else {
+		p++;
+	    }
+	    break;
 
-	    case '[':
-		if (doCmds) {
-		    if (p != old) {
-			Tcl_DStringAppend(&result, old, p-old);
-		    }
-		    iPtr->evalFlags = TCL_BRACKET_TERM;
-		    code = Tcl_Eval(interp, p+1);
-		    if (code == TCL_ERROR) {
-			Tcl_DStringFree(&result);
-			return code;
-		    }
-		    old = p = (p+1 + iPtr->termOffset+1);
-		    Tcl_DStringAppend(&result, iPtr->result, -1);
+	case '[':
+	    if (flags & TCL_SUBST_COMMANDS) {
+		Interp *iPtr = (Interp *) interp;
+		int code;
+
+		if (p != old) {
+		    Tcl_AppendToObj(resultObj, old, p-old);
+		}
+		iPtr->evalFlags = TCL_BRACKET_TERM;
+		code = Tcl_EvalEx(interp, p+1, -1, 0);
+		switch (code) {
+		case TCL_ERROR:
+		    goto errorResult;
+		case TCL_BREAK:
 		    Tcl_ResetResult(interp);
-		} else {
-		    p++;
+		    return resultObj;
+		default:
+		    Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
+		case TCL_CONTINUE:
+		    Tcl_ResetResult(interp);
+		    old = p = (p+1 + iPtr->termOffset + 1);
 		}
-		break;
-
-	    default:
+	    } else {
 		p++;
-		break;
+	    }
+	    break;
+	default:
+	    p++;
+	    break;
 	}
     }
-    if (p != old) {
-	Tcl_DStringAppend(&result, old, p-old);
-    }
-    Tcl_DStringResult(interp, &result);
-    return TCL_OK;
+
+ errorResult:
+    Tcl_DecrRefCount(resultObj);
+    return NULL;
 }
 
 /*
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index bb600ed..2e94d6a 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.51 2001/06/08 20:06:11 dgp Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.52 2001/07/12 13:15:09 dkf Exp $
  */
 
 #ifndef _TCLDECLS
@@ -1368,6 +1368,9 @@ EXTERN int		Tcl_GetMathFuncInfo _ANSI_ARGS_((Tcl_Interp * interp,
 /* 436 */
 EXTERN Tcl_Obj *	Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp * interp, 
 				CONST char * pattern));
+/* 437 */
+EXTERN Tcl_Obj *	Tcl_SubstObj _ANSI_ARGS_((Tcl_Interp * interp, 
+				Tcl_Obj * objPtr, int flags));
 
 typedef struct TclStubHooks {
     struct TclPlatStubs *tclPlatStubs;
@@ -1864,6 +1867,7 @@ typedef struct TclStubs {
     Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 434 */
     int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * numArgsPtr, Tcl_ValueType ** argTypesPtr, Tcl_MathProc ** procPtr, ClientData * clientDataPtr)); /* 435 */
     Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 436 */
+    Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
 } TclStubs;
 
 #ifdef __cplusplus
@@ -3652,6 +3656,10 @@ extern TclStubs *tclStubsPtr;
 #define Tcl_ListMathFuncs \
 	(tclStubsPtr->tcl_ListMathFuncs) /* 436 */
 #endif
+#ifndef Tcl_SubstObj
+#define Tcl_SubstObj \
+	(tclStubsPtr->tcl_SubstObj) /* 437 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index cf8b8b9..1fe3582 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.52 2001/06/17 03:48:19 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.53 2001/07/12 13:15:09 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -832,6 +832,7 @@ TclStubs tclStubs = {
     Tcl_GetUnicodeFromObj, /* 434 */
     Tcl_GetMathFuncInfo, /* 435 */
     Tcl_ListMathFuncs, /* 436 */
+    Tcl_SubstObj, /* 437 */
 };
 
 /* !END!: Do not edit above this line. */