Attachment "684982.patch" to
ticket [684982ffff]
added by
dgp
2003-03-09 04:40:55.
? unix/dltest.marker
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.76
diff -u -r1.76 tclBasic.c
--- generic/tclBasic.c 5 Mar 2003 22:31:22 -0000 1.76
+++ generic/tclBasic.c 8 Mar 2003 21:21:20 -0000
@@ -346,7 +346,6 @@
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
iPtr->cmdCount = 0;
- iPtr->termOffset = 0;
TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
iPtr->compiledProcPtr = NULL;
@@ -3347,143 +3346,7 @@
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
- Tcl_Obj *resultPtr, *indexPtr, *valuePtr;
- char buffer[TCL_UTF_MAX];
-#ifdef TCL_MEM_DEBUG
-# define MAX_VAR_CHARS 5
-#else
-# define MAX_VAR_CHARS 30
-#endif
- char nameBuffer[MAX_VAR_CHARS+1];
- char *varName, *index;
- CONST char *p = NULL; /* Initialized to avoid compiler warning. */
- int length, code;
-
- /*
- * The only tricky thing about this procedure is that it attempts to
- * avoid object creation and string copying whenever possible. For
- * example, if the value is just a nested command, then use the
- * command's result object directly.
- */
-
- code = TCL_OK;
- resultPtr = NULL;
- Tcl_ResetResult(interp);
- for ( ; count > 0; count--, tokenPtr++) {
- valuePtr = NULL;
-
- /*
- * The switch statement below computes the next value to be
- * concat to the result, as either a range of text or an
- * object.
- */
-
- switch (tokenPtr->type) {
- case TCL_TOKEN_TEXT:
- p = tokenPtr->start;
- length = tokenPtr->size;
- break;
-
- case TCL_TOKEN_BS:
- length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
- buffer);
- p = buffer;
- break;
-
- case TCL_TOKEN_COMMAND:
- code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
- 0);
- if (code != TCL_OK) {
- goto done;
- }
- valuePtr = Tcl_GetObjResult(interp);
- break;
-
- case TCL_TOKEN_VARIABLE:
- if (tokenPtr->numComponents == 1) {
- indexPtr = NULL;
- index = NULL;
- } else {
- code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
- tokenPtr->numComponents - 1);
- if (code != TCL_OK) {
- goto done;
- }
- indexPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(indexPtr);
- index = Tcl_GetString(indexPtr);
- }
-
- /*
- * We have to make a copy of the variable name in order
- * to have a null-terminated string. We can't make a
- * temporary modification to the script to null-terminate
- * the name, because a trace callback might potentially
- * reuse the script and be affected by the null character.
- */
-
- if (tokenPtr[1].size <= MAX_VAR_CHARS) {
- varName = nameBuffer;
- } else {
- varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
- }
- strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
- varName[tokenPtr[1].size] = 0;
- valuePtr = Tcl_GetVar2Ex(interp, varName, index,
- TCL_LEAVE_ERR_MSG);
- if (varName != nameBuffer) {
- ckfree(varName);
- }
- if (indexPtr != NULL) {
- Tcl_DecrRefCount(indexPtr);
- }
- if (valuePtr == NULL) {
- code = TCL_ERROR;
- goto done;
- }
- count -= tokenPtr->numComponents;
- tokenPtr += tokenPtr->numComponents;
- break;
-
- default:
- panic("unexpected token type in Tcl_EvalTokensStandard");
- }
-
- /*
- * If valuePtr isn't NULL, the next piece of text comes from that
- * object; otherwise, take length bytes starting at p.
- */
-
- if (resultPtr == NULL) {
- if (valuePtr != NULL) {
- resultPtr = valuePtr;
- } else {
- resultPtr = Tcl_NewStringObj(p, length);
- }
- Tcl_IncrRefCount(resultPtr);
- } else {
- if (Tcl_IsShared(resultPtr)) {
- Tcl_DecrRefCount(resultPtr);
- resultPtr = Tcl_DuplicateObj(resultPtr);
- Tcl_IncrRefCount(resultPtr);
- }
- if (valuePtr != NULL) {
- p = Tcl_GetStringFromObj(valuePtr, &length);
- }
- Tcl_AppendToObj(resultPtr, p, length);
- }
- }
- if (resultPtr != NULL) {
- Tcl_SetObjResult(interp, resultPtr);
- } else {
- code = TCL_ERROR;
- }
-
- done:
- if (resultPtr != NULL) {
- Tcl_DecrRefCount(resultPtr);
- }
- return code;
+ return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL);
}
@@ -3579,7 +3442,7 @@
#define NUM_STATIC_OBJS 20
Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
Tcl_Token *tokenPtr;
- int i, code, commandLength, bytesLeft, nested;
+ int i, code, commandLength, bytesLeft;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
@@ -3610,31 +3473,14 @@
objv = staticObjArray;
p = script;
bytesLeft = numBytes;
- if (iPtr->evalFlags & TCL_BRACKET_TERM) {
- nested = 1;
- } else {
- nested = 0;
- }
iPtr->evalFlags = 0;
do {
- if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
+ if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse)
!= TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
-
- if (nested && parse.term == (script + numBytes)) {
- /*
- * A nested script can only terminate in ']'. If
- * the parsing got terminated at the end of the script,
- * there was no closing ']'. Report the syntax error.
- */
-
- code = TCL_ERROR;
- goto error;
- }
-
if (parse.numWords > 0) {
/*
* Generate an array of objects for the words of the command.
@@ -3649,8 +3495,8 @@
for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
objectsUsed < parse.numWords;
objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
- code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
- tokenPtr->numComponents);
+ code = TclSubstTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, NULL);
if (code == TCL_OK) {
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
@@ -3703,20 +3549,7 @@
p = next;
Tcl_FreeParse(&parse);
gotParse = 0;
- if (nested && (*parse.term == ']')) {
- /*
- * We get here in the special case where the TCL_BRACKET_TERM
- * flag was set in the interpreter and the latest parsed command
- * was terminated by the matching close-bracket we seek.
- * Return immediately.
- */
-
- iPtr->termOffset = (p - 1) - script;
- iPtr->varFramePtr = savedVarFramePtr;
- return TCL_OK;
- }
} while (bytesLeft > 0);
- iPtr->termOffset = p - script;
iPtr->varFramePtr = savedVarFramePtr;
return TCL_OK;
@@ -3753,85 +3586,6 @@
ckfree((char *) objv);
}
iPtr->varFramePtr = savedVarFramePtr;
-
- /*
- * All that's left to do before returning is to set iPtr->termOffset
- * to point past the end of the script we just evaluated.
- */
-
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= next - p;
- p = next;
-
- if (!nested) {
- iPtr->termOffset = p - script;
- return code;
- }
-
- /*
- * When we are nested (the TCL_BRACKET_TERM flag was set in the
- * interpreter), we must find the matching close-bracket to
- * end the script we are evaluating.
- *
- * When our return code is TCL_CONTINUE or TCL_RETURN, we want
- * to correctly set iPtr->termOffset to point to that matching
- * close-bracket so our caller can move to the part of the
- * string beyond the script we were asked to evaluate.
- * So we try to parse past the rest of the commands.
- */
-
- next = NULL;
- while (bytesLeft && (*parse.term != ']')) {
- if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) {
- /*
- * Syntax error. Set the termOffset to the beginning of
- * the last command parsed.
- */
-
- if (next == NULL) {
- iPtr->termOffset = (parse.commandStart - 1) - script;
- } else {
- iPtr->termOffset = (next - 1) - script;
- }
- return code;
- }
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= next - p;
- p = next;
- next = parse.commandStart;
- Tcl_FreeParse(&parse);
- }
-
- if (bytesLeft) {
- /*
- * parse.term points to the close-bracket.
- */
-
- iPtr->termOffset = parse.term - script;
- } else if (parse.term == script + numBytes) {
- /*
- * There was no close-bracket. Syntax error.
- */
-
- iPtr->termOffset = parse.term - script;
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("missing close-bracket", -1));
- return TCL_ERROR;
- } else if (*parse.term != ']') {
- /*
- * There was no close-bracket. Syntax error.
- */
-
- iPtr->termOffset = (parse.term + 1) - script;
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("missing close-bracket", -1));
- return TCL_ERROR;
- } else {
- /*
- * parse.term points to the close-bracket.
- */
- iPtr->termOffset = parse.term - script;
- }
return code;
}
@@ -3932,9 +3686,6 @@
* holds the bytecode instructions for the commands. Executing the
* commands will almost certainly have side effects that depend
* on those commands.
- *
- * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
- * last character executed in the objPtr's string.
*
*----------------------------------------------------------------------
*/
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.82
diff -u -r1.82 tclCmdMZ.c
--- generic/tclCmdMZ.c 27 Feb 2003 00:54:36 -0000 1.82
+++ generic/tclCmdMZ.c 8 Mar 2003 21:22:01 -0000
@@ -2490,159 +2490,6 @@
/*
*----------------------------------------------------------------------
*
- * Tcl_SubstObj --
- *
- * This function performs the substitutions specified 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 (or at least hard to characterise.) This fault
- * will be fixed at some point, but the cost of the only sane
- * fix (well-formedness check first) is such that you need to
- * "precompile and cache" to stop everyone from being hit with
- * the consequences every time through. Note that the current
- * behaviour is not a security hole; it just restarts parsing
- * the string following the substitution in a mildly surprising
- * place, and it is a very bad idea to count on this remaining
- * the same in future...
- *
- * 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 0:
- if (p != old) {
- Tcl_AppendToObj(resultObj, old, p-old);
- }
- return resultObj;
-
- case '\\':
- if (flags & TCL_SUBST_BACKSLASHES) {
- char buf[TCL_UTF_MAX];
- int count;
-
- if (p != old) {
- Tcl_AppendToObj(resultObj, old, p-old);
- }
- Tcl_AppendToObj(resultObj, buf,
- Tcl_UtfBackslash(p, &count, buf));
- p += count;
- old = p;
- } else {
- p++;
- }
- break;
-
- case '$':
- if (flags & TCL_SUBST_VARIABLES) {
- Tcl_Parse parse;
- int code;
-
- /*
- * 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;
- }
- if (p != old) {
- Tcl_AppendToObj(resultObj, old, p-old);
- }
- p += parse.tokenPtr->size;
- code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
- parse.numTokens);
- if (code == TCL_ERROR) {
- goto errorResult;
- }
- if (code == TCL_BREAK) {
- Tcl_ResetResult(interp);
- return resultObj;
- }
- if (code != TCL_CONTINUE) {
- Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
- }
- Tcl_ResetResult(interp);
- old = p;
- } else {
- p++;
- }
- break;
-
- 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);
- return resultObj;
- default:
- Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
- case TCL_CONTINUE:
- Tcl_ResetResult(interp);
- old = p = (p+1 + iPtr->termOffset + 1);
- }
- } else {
- p++;
- }
- break;
- default:
- p++;
- break;
- }
- }
-
- errorResult:
- Tcl_DecrRefCount(resultObj);
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_SwitchObjCmd --
*
* This object-based procedure is invoked to process the "switch" Tcl
Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.41
diff -u -r1.41 tclCompCmds.c
--- generic/tclCompCmds.c 6 Mar 2003 23:17:09 -0000 1.41
+++ generic/tclCompCmds.c 8 Mar 2003 21:22:34 -0000
@@ -3140,7 +3140,7 @@
TclEmitOpcode(INST_POP, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
code = TclCompileScript(interp, bodyTokenArray[i+1].start,
- bodyTokenArray[i+1].size, /*nested*/ 0, envPtr);
+ bodyTokenArray[i+1].size, envPtr);
if (code != TCL_OK) {
ckfree((char *)argv);
ckfree((char *)bodyTokenArray);
Index: generic/tclCompExpr.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompExpr.c,v
retrieving revision 1.13
diff -u -r1.13 tclCompExpr.c
--- generic/tclCompExpr.c 16 Feb 2003 01:36:32 -0000 1.13
+++ generic/tclCompExpr.c 8 Mar 2003 21:22:43 -0000
@@ -398,7 +398,7 @@
case TCL_TOKEN_COMMAND:
code = TclCompileScript(interp, tokenPtr->start+1,
- tokenPtr->size-2, /*nested*/ 0, envPtr);
+ tokenPtr->size-2, envPtr);
if (code != TCL_OK) {
goto done;
}
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.43
diff -u -r1.43 tclCompile.c
--- generic/tclCompile.c 19 Feb 2003 14:33:39 -0000 1.43
+++ generic/tclCompile.c 8 Mar 2003 21:23:17 -0000
@@ -348,14 +348,16 @@
CompileHookProc *hookProc; /* Procedure to invoke after compilation. */
ClientData clientData; /* Hook procedure private data. */
{
+#ifdef TCL_COMPILE_DEBUG
Interp *iPtr = (Interp *) interp;
+#endif /*TCL_COMPILE_DEBUG*/
CompileEnv compEnv; /* Compilation environment structure
* allocated in frame. */
LiteralTable *localTablePtr = &(compEnv.localLitTable);
register AuxData *auxDataPtr;
LiteralEntry *entryPtr;
register int i;
- int length, nested, result;
+ int length, result;
char *string;
#ifdef TCL_COMPILE_DEBUG
@@ -368,21 +370,15 @@
}
#endif
- if (iPtr->evalFlags & TCL_BRACKET_TERM) {
- nested = 1;
- } else {
- nested = 0;
- }
string = Tcl_GetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length);
- result = TclCompileScript(interp, string, length, nested, &compEnv);
+ result = TclCompileScript(interp, string, length, &compEnv);
if (result == TCL_OK) {
/*
* Successful compilation. Add a "done" instruction at the end.
*/
- compEnv.numSrcBytes = iPtr->termOffset;
TclEmitOpcode(INST_DONE, &compEnv);
/*
@@ -786,10 +782,6 @@
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * interp->termOffset is set to the offset of the character in the
- * script just after the last one successfully processed; this will be
- * the offset of the ']' if (flags & TCL_BRACKET_TERM).
- *
* Side effects:
* Adds instructions to envPtr to evaluate the script at runtime.
*
@@ -797,7 +789,7 @@
*/
int
-TclCompileScript(interp, script, numBytes, nested, envPtr)
+TclCompileScript(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting.
* Also serves as context for finding and
* compiling commands. May not be NULL. */
@@ -805,10 +797,6 @@
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
- int nested; /* Non-zero means this is a nested command:
- * close bracket ']' should be considered a
- * command terminator. If zero, close
- * bracket has no special meaning. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Interp *iPtr = (Interp *) interp;
@@ -845,55 +833,11 @@
bytesLeft = numBytes;
gotParse = 0;
do {
- if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
+ if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
- if (nested) {
- /*
- * This is an unusual situation where the caller has passed us
- * a non-zero value for "nested". How unusual? Well, this
- * procedure, TclCompileScript, is internal to Tcl, so all
- * callers should be within Tcl itself. All but one of those
- * callers explicitly pass in (nested = 0). The exceptional
- * caller is TclSetByteCodeFromAny, which will pass in
- * (nested = 1) if and only if the flag TCL_BRACKET_TERM
- * is set in the evalFlags field of interp.
- *
- * It appears that the TCL_BRACKET_TERM flag is only ever set
- * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx
- * which clears the flag before passing the interp along.
- * So, I don't think this procedure, TclCompileScript, is
- * **ever** called with (nested != 0).
- * (The testsuite indeed doesn't exercise this code. MS)
- *
- * This means that the branches in this procedure that are
- * only active when (nested != 0) are probably never exercised.
- * This means that any bugs in them go unnoticed, and any bug
- * fixes in them have a semi-theoretical nature.
- *
- * All that said, the spec for this procedure says it should
- * handle the (nested != 0) case, so here's an attempt to fix
- * bugs (Tcl Bug 681841) in that case. Just in case some
- * callers eventually come along and expect it to work...
- */
-
- if (parse.term == (script + numBytes)) {
- /*
- * The (nested != 0) case is meant to indicate that the
- * caller found an open bracket ([) and asked us to
- * parse and compile Tcl commands up to the matching
- * close bracket (]). We have to detect and handle
- * the case where the close bracket is missing.
- */
-
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("missing close-bracket", -1));
- code = TCL_ERROR;
- goto error;
- }
- }
if (parse.numWords > 0) {
/*
* If not the first command, pop the previous command's result
@@ -903,11 +847,8 @@
if (!isFirstCmd) {
TclEmitOpcode(INST_POP, envPtr);
- if (!nested) {
- envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - startCodeOffset;
- }
+ envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart) - startCodeOffset;
}
/*
@@ -931,8 +872,7 @@
* If tracing, print a line for each top level command compiled.
*/
- if ((tclTraceCompile >= 1)
- && !nested && (envPtr->procPtr == NULL)) {
+ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
fprintf(stdout, " Compiling: ");
TclPrintSource(stdout, parse.commandStart,
TclMin(commandLength, 55));
@@ -946,9 +886,7 @@
envPtr->numCommands++;
currCmdIndex = (envPtr->numCommands - 1);
- if (!nested) {
- lastTopLevelCmdIndex = currCmdIndex;
- }
+ lastTopLevelCmdIndex = currCmdIndex;
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
@@ -1071,16 +1009,6 @@
p = next;
Tcl_FreeParse(&parse);
gotParse = 0;
- if (nested && (*parse.term == ']')) {
- /*
- * We get here in the special case where TCL_BRACKET_TERM was
- * set in the interpreter and the latest parsed command was
- * terminated by the matching close-bracket we were looking for.
- * Stop compilation.
- */
-
- break;
- }
} while (bytesLeft > 0);
/*
@@ -1093,17 +1021,7 @@
envPtr);
}
- if (nested) {
- /*
- * When (nested != 0) back up 1 character to have
- * iPtr->termOffset indicate the offset to the matching
- * close-bracket.
- */
-
- iPtr->termOffset = (p - 1) - script;
- } else {
- iPtr->termOffset = (p - script);
- }
+ envPtr->numSrcBytes = (p - script);
Tcl_DStringFree(&ds);
return TCL_OK;
@@ -1132,7 +1050,7 @@
if (gotParse) {
Tcl_FreeParse(&parse);
}
- iPtr->termOffset = (p - script);
+ envPtr->numSrcBytes = (p - script);
Tcl_DStringFree(&ds);
return code;
}
@@ -1207,7 +1125,7 @@
}
code = TclCompileScript(interp, tokenPtr->start+1,
- tokenPtr->size-2, /*nested*/ 0, envPtr);
+ tokenPtr->size-2, envPtr);
if (code != TCL_OK) {
goto error;
}
@@ -1396,8 +1314,7 @@
*/
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
- code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
- /*nested*/ 0, envPtr);
+ code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
return code;
}
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.34
diff -u -r1.34 tclCompile.h
--- generic/tclCompile.h 5 Mar 2003 22:31:23 -0000 1.34
+++ generic/tclCompile.h 8 Mar 2003 21:23:28 -0000
@@ -748,8 +748,7 @@
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr));
EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp,
- CONST char *script, int numBytes, int nested,
- CompileEnv *envPtr));
+ CONST char *script, int numBytes, CompileEnv *envPtr));
EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr));
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.94
diff -u -r1.94 tclExecute.c
--- generic/tclExecute.c 19 Feb 2003 14:33:39 -0000 1.94
+++ generic/tclExecute.c 8 Mar 2003 21:24:21 -0000
@@ -831,7 +831,6 @@
* and aux data items is given to the ByteCode object.
*/
- compEnv.numSrcBytes = iPtr->termOffset;
TclEmitOpcode(INST_DONE, &compEnv);
TclInitByteCodeObj(objPtr, &compEnv);
TclFreeCompileEnv(&compEnv);
@@ -1037,16 +1036,7 @@
}
}
- /*
- * Set the interpreter's termOffset member to the offset of the
- * character just after the last one executed. We approximate the offset
- * of the last character executed by using the number of characters
- * compiled.
- */
-
- iPtr->termOffset = numSrcBytes;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
-
return result;
}
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.119
diff -u -r1.119 tclInt.h
--- generic/tclInt.h 5 Mar 2003 22:31:24 -0000 1.119
+++ generic/tclInt.h 8 Mar 2003 21:24:47 -0000
@@ -1249,8 +1249,7 @@
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
- int termOffset; /* Offset of character just after last one
- * compiled or executed by Tcl_EvalObj. */
+ int unused1; /* No longer used (was termOffset) */
LiteralTable literalTable; /* Contains LiteralEntry's describing all
* Tcl objects holding literals of scripts
* compiled by the interpreter. Indexed by
@@ -1320,14 +1319,11 @@
/*
* EvalFlag bits for Interp structures:
*
- * TCL_BRACKET_TERM 1 means that the current script is terminated by
- * a close bracket rather than the end of the string.
* TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with
* a code other than TCL_OK or TCL_ERROR; 0 means
* codes other than these should be turned into errors.
*/
-#define TCL_BRACKET_TERM 1
#define TCL_ALLOW_EXCEPTIONS 4
/*
@@ -1802,7 +1798,10 @@
EXTERN VOID TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id));
EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
- int result));
+ int result));
+EXTERN int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, int count,
+ int *tokensLeftPtr));
EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
int result, Tcl_Interp *targetInterp));
EXTERN Tcl_Obj* TclpNativeToNormalized
Index: generic/tclParse.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParse.c,v
retrieving revision 1.25
diff -u -r1.25 tclParse.c
--- generic/tclParse.c 16 Feb 2003 01:36:32 -0000 1.25
+++ generic/tclParse.c 8 Mar 2003 21:25:06 -0000
@@ -179,7 +179,7 @@
static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_Parse *parsePtr));
static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
- int mask, Tcl_Parse *parsePtr));
+ int mask, int flags, Tcl_Parse *parsePtr));
/*
*----------------------------------------------------------------------
@@ -343,7 +343,7 @@
*/
if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
- parsePtr) != TCL_OK) {
+ TCL_SUBST_ALL, parsePtr) != TCL_OK) {
goto error;
}
src = parsePtr->term; numBytes = parsePtr->end - src;
@@ -785,9 +785,13 @@
*/
static int
-ParseTokens(src, numBytes, mask, parsePtr)
+ParseTokens(src, numBytes, mask, flags, parsePtr)
register CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
+ int flags; /* OR-ed bits indicating what substitutions
+ to perform: TCL_SUBST_COMMANDS,
+ TCL_SUBST_VARIABLES, and
+ TCL_SUBST_BACKSLASHES */
int mask; /* Specifies when to stop parsing. The
* parse stops at the first unquoted
* character whose CHAR_TYPE contains
@@ -798,6 +802,9 @@
{
char type;
int originalTokens, varToken;
+ int noSubstCmds = !(flags & TCL_SUBST_COMMANDS);
+ int noSubstVars = !(flags & TCL_SUBST_VARIABLES);
+ int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES);
Tcl_Token *tokenPtr;
Tcl_Parse nested;
@@ -831,6 +838,13 @@
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '$') {
+ if (noSubstVars) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ continue;
+ }
/*
* This is a variable reference. Call Tcl_ParseVarName to do
* all the dirty work of parsing the name.
@@ -844,6 +858,13 @@
src += parsePtr->tokenPtr[varToken].size;
numBytes -= parsePtr->tokenPtr[varToken].size;
} else if (*src == '[') {
+ if (noSubstCmds) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ continue;
+ }
/*
* Command substitution. Call Tcl_ParseCommand recursively
* (and repeatedly) to parse the nested command(s), then
@@ -896,6 +917,13 @@
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '\\') {
+ if (noSubstBS) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ continue;
+ }
/*
* Backslash substitution.
*/
@@ -1210,8 +1238,8 @@
* since it could contain any number of substitutions.
*/
- if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr)
- != TCL_OK) {
+ if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
+ TCL_SUBST_ALL, parsePtr)) {
goto error;
}
if ((parsePtr->term == (src + numBytes))
@@ -1302,7 +1330,7 @@
return "$";
}
- code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens);
+ code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL);
if (code != TCL_OK) {
return NULL;
}
@@ -1606,7 +1634,8 @@
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
- if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) {
+ if (TCL_OK != ParseTokens(string+1, numBytes-1, TYPE_QUOTE,
+ TCL_SUBST_ALL, parsePtr)) {
goto error;
}
if (*parsePtr->term != '"') {
@@ -1628,6 +1657,261 @@
return TCL_ERROR;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SubstObj --
+ *
+ * This function performs the substitutions specified on the
+ * given string as described in the user documentation for the
+ * "subst" Tcl command.
+ *
+ * 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; /* Interpreter in which substitution occurs */
+ Tcl_Obj *objPtr; /* The value to be substituted */
+ int flags; /* What substitutions to do */
+{
+ int length, tokensLeft, code;
+ Tcl_Parse parse;
+ Tcl_Token *endTokenPtr;
+ Tcl_Obj *result;
+ CONST char *p = Tcl_GetStringFromObj(objPtr, &length);
+
+ parse.tokenPtr = parse.staticTokens;
+ parse.numTokens = 0;
+ parse.tokensAvailable = NUM_STATIC_TOKENS;
+ parse.string = p;
+ parse.end = p + length;
+ parse.term = parse.end;
+ parse.interp = interp;
+ parse.incomplete = 0;
+ parse.errorType = TCL_PARSE_SUCCESS;
+
+ /*
+ * First parse the string rep of objPtr, as if it were enclosed
+ * as a "-quoted word in a normal Tcl command. Parse errors
+ * cause immediate error reporting. Honor flags that selectively
+ * inhibit types of substitution.
+ */
+
+ if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) {
+ return NULL;
+ }
+
+ /* Next, substitute the parsed tokens just as in normal Tcl evaluation */
+ endTokenPtr = parse.tokenPtr + parse.numTokens;
+ tokensLeft = parse.numTokens;
+ code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
+ &tokensLeft);
+ if (code == TCL_OK) {
+ Tcl_FreeParse(&parse);
+ return Tcl_GetObjResult(interp);
+ }
+ result = Tcl_NewObj();
+ while (1) {
+ switch (code) {
+ case TCL_ERROR:
+ Tcl_FreeParse(&parse);
+ Tcl_DecrRefCount(result);
+ return NULL;
+ case TCL_BREAK:
+ tokensLeft = 0; /* Halt substitution */
+ default:
+ Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp));
+ }
+
+ if (tokensLeft == 0) {
+ Tcl_FreeParse(&parse);
+ return result;
+ }
+
+ code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
+ &tokensLeft);
+ }
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSubstTokens --
+ *
+ * Accepts an array of count Tcl_Token's, and creates a result
+ * value in the interp from concatenating the results of
+ * performing Tcl substitution on each Tcl_Token. Substitution
+ * is interrupted if any non-TCL_OK completion code arises.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code. The
+ * result in interp is the substituted value, or an error message
+ * if TCL_ERROR is returned. If tokensLeftPtr is not NULL, then
+ * it points to an int where the number of tokens remaining to
+ * be processed is written.
+ *
+ * Side effects:
+ * Can be anything, depending on the types of substitution done.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr)
+ 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 *tokensLeftPtr; /* If not NULL, points to memory where an
+ * integer representing the number of tokens
+ * left to be substituted will be written */
+{
+ Tcl_Obj *result;
+ int code = TCL_OK;
+
+ /*
+ * Each pass through this loop will substitute one token, and its
+ * components, if any. The only thing tricky here is that we go to
+ * some effort to pass Tcl_Obj's through untouched, to avoid string
+ * copying and Tcl_Obj creation if possible, to aid performance and
+ * limit shimmering.
+ *
+ * Further optimization opportunities might be to check for the
+ * equivalent of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp))
+ * and omit them.
+ */
+
+ result = NULL;
+ for ( ; (count > 0) && (code == TCL_OK); count--, tokenPtr++) {
+ Tcl_Obj *appendObj = NULL;
+ CONST char *append = NULL;
+ int appendByteLength = 0;
+
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_TEXT:
+ append = tokenPtr->start;
+ appendByteLength = tokenPtr->size;
+ break;
+
+ case TCL_TOKEN_BS: {
+ char utfCharBytes[TCL_UTF_MAX];
+ appendByteLength = Tcl_UtfBackslash(tokenPtr->start,
+ (int *) NULL, utfCharBytes);
+ append = utfCharBytes;
+ break;
+ }
+
+ case TCL_TOKEN_COMMAND:
+ code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
+ 0);
+ appendObj = Tcl_GetObjResult(interp);
+ break;
+
+ case TCL_TOKEN_VARIABLE: {
+ Tcl_Obj *arrayIndex = NULL;
+ Tcl_Obj *varName = NULL;
+ if (tokenPtr->numComponents > 1) {
+ /* Subst the index part of an array variable reference */
+ code = TclSubstTokens(interp, tokenPtr+2,
+ tokenPtr->numComponents - 1, NULL);
+ arrayIndex = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(arrayIndex);
+ }
+
+ if (code == TCL_OK) {
+ varName = Tcl_NewStringObj(tokenPtr[1].start,
+ tokenPtr[1].size);
+ appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex,
+ TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(varName);
+ if (appendObj == NULL) {
+ code = TCL_ERROR;
+ }
+ }
+
+ switch (code) {
+ case TCL_OK: /* Got value */
+ case TCL_ERROR: /* Already have error message */
+ case TCL_BREAK: /* Will not substitute anyway */
+ case TCL_CONTINUE: /* Will not substitute anyway */
+ break;
+ default:
+ /* All other return codes, we will subst the
+ * result from the code-throwing evaluation */
+ appendObj = Tcl_GetObjResult(interp);
+ }
+
+ if (arrayIndex != NULL) {
+ Tcl_DecrRefCount(arrayIndex);
+ }
+ count -= tokenPtr->numComponents;
+ tokenPtr += tokenPtr->numComponents;
+ break;
+ }
+
+ default:
+ Tcl_Panic("unexpected token type in TclSubstTokens: %d",
+ tokenPtr->type);
+ }
+
+ if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) {
+ /* Inhibit substitution */
+ continue;
+ }
+
+ if (result == NULL) {
+ /*
+ * First pass through. If we have a Tcl_Obj, just use it.
+ * If not, create one from our string.
+ */
+
+ if (appendObj != NULL) {
+ result = appendObj;
+ } else {
+ result = Tcl_NewStringObj(append, appendByteLength);;
+ }
+ Tcl_IncrRefCount(result);
+ } else {
+ /* Subsequent passes. Append to result. */
+ if (Tcl_IsShared(result)) {
+ Tcl_DecrRefCount(result);
+ result = Tcl_DuplicateObj(result);
+ Tcl_IncrRefCount(result);
+ }
+ if (appendObj != NULL) {
+ Tcl_AppendObjToObj(result, appendObj);
+ } else {
+ Tcl_AppendToObj(result, append, appendByteLength);
+ }
+ }
+ }
+
+ if (code != TCL_ERROR) { /* Keep error message in result! */
+ if (result != NULL) {
+ Tcl_SetObjResult(interp, result);
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ }
+ if (tokensLeftPtr != NULL) {
+ *tokensLeftPtr = count;
+ }
+ if (result != NULL) {
+ Tcl_DecrRefCount(result);
+ }
+ return code;
+}
+
/*
*----------------------------------------------------------------------
*
Index: tests/subst.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/subst.test,v
retrieving revision 1.13
diff -u -r1.13 subst.test
--- tests/subst.test 16 Feb 2003 01:36:32 -0000 1.13
+++ tests/subst.test 8 Mar 2003 21:25:12 -0000
@@ -14,7 +14,7 @@
# RCS: @(#) $Id: subst.test,v 1.13 2003/02/16 01:36:32 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2.1
namespace import -force ::tcltest::*
}
@@ -93,7 +93,7 @@
test subst-5.7 {command substitutions} {
set a 0
list [catch {subst {0[set a 1; set a 2}} msg] $a $msg
-} {1 1 {missing close-bracket}}
+} {1 0 {missing close-bracket}}
# repeat the tests above simulating cmd line input
test subst-5.8 {command substitutions} {
@@ -158,12 +158,12 @@
test subst-8.6 {return in a subst} {
list [catch {subst {foo [return {x}; bogus code bar}} msg] $msg
} {1 {missing close-bracket}}
-test subst-8.7 {return in a subst, parse error} {
+test subst-8.7 {return in a subst, parse error} -body {
subst {foo [return {x} ; set a {}" ; stuff] bar}
-} {foo xset a {}" ; stuff] bar}
-test subst-8.8 {return in a subst, parse error} {
+} -returnCodes error -result {extra characters after close-brace}
+test subst-8.8 {return in a subst, parse error} -body {
subst {foo [return {x} ; set bar baz ; set a {}" ; stuff] bar}
-} {foo xset bar baz ; set a {}" ; stuff] bar}
+} -returnCodes error -result {extra characters after close-brace}
test subst-8.9 {return in a variable subst} {
subst {foo $var([return {x}]) bar}
} {foo x bar}
@@ -187,12 +187,12 @@
test subst-10.3 {break in a subst} {
subst {foo [if 1 { break; bogus code}] bar}
} {foo }
-test subst-10.4 {break in a subst, parse error} {
+test subst-10.4 {break in a subst, parse error} -body {
subst {foo [break ; set a {}{} ; stuff] bar}
-} {foo }
-test subst-10.5 {break in a subst, parse error} {
+} -returnCodes error -result {extra characters after close-brace}
+test subst-10.5 {break in a subst, parse error} -body {
subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar}
-} {foo }
+} -returnCodes error -result {extra characters after close-brace}
test subst-10.6 {break in a variable subst} {
subst {foo $var([break]) bar}
} {foo }
@@ -206,15 +206,19 @@
test subst-11.3 {continue in a subst} {
subst {foo [if 1 { continue; bogus code}] bar}
} {foo bar}
-test subst-11.4 {continue in a subst, parse error} {
+test subst-11.4 {continue in a subst, parse error} -body {
subst {foo [continue ; set a {}{} ; stuff] bar}
-} {foo set a {}{} ; stuff] bar}
-test subst-11.5 {continue in a subst, parse error} {
+} -returnCodes error -result {extra characters after close-brace}
+test subst-11.5 {continue in a subst, parse error} -body {
subst {foo [continue ;set bar baz ;set a {}{} ; stuff] bar}
-} {foo set bar baz ;set a {}{} ; stuff] bar}
+} -returnCodes error -result {extra characters after close-brace}
test subst-11.6 {continue in a variable subst} {
subst {foo $var([continue]) bar}
} {foo bar}
+
+test subst-bug-685106 {Tcl_SubstObj halts on NULL} {
+ subst [bytestring bar\x00soom]
+} [bytestring bar\x00soom]
# cleanup
::tcltest::cleanupTests
