diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclBasic.c | 905 | ||||
| -rw-r--r-- | generic/tclParse.c | 907 |
3 files changed, 916 insertions, 907 deletions
@@ -1,3 +1,14 @@ +2001-11-16 Miguel Sofer <msofer@users.sourceforge.net> + + * generic/tclBasic.c: + * generic/tclParse.c: Code reorganisation. Moved all evaluation + functions from tclParse.c to tclBasic.c, so that now tclParse.c + deals exclusively with parsing and all evaluations are done by + code in tclBasic.c. The functions moved are: TclEvalObjvInternal, + Tcl_EvalObjv, Tcl_LogCommandInfo, Tcl_EvalTokensStandard, + Tcl_EvalTokens, Tcl_EvalEx, Tcl_Eval, Tcl_EvalObj and + Tcl_GlobalEvalObj. + 2001-11-19 Donal K. Fellows <fellowsd@cs.man.ac.uk> * tests/trace.test (trace-8.8): Added adapted version of Bug diff --git a/generic/tclBasic.c b/generic/tclBasic.c index edb8bb6..fc5e49e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3,7 +3,7 @@ * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation - * and deletion, and command parsing and execution. + * and deletion, and command/script execution. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -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: tclBasic.c,v 1.37 2001/11/16 20:01:04 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.38 2001/11/19 17:30:27 msofer Exp $ */ #include "tclInt.h" @@ -2723,6 +2723,907 @@ Tcl_ListMathFuncs(interp, pattern) /* *---------------------------------------------------------------------- * + * TclEvalObjvInternal -- + * + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. + * + * Results: + * 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. If an error occurs, this procedure does + * NOT add any information to the errorInfo variable. + * + * Side effects: + * Depends on the command. + * + *---------------------------------------------------------------------- + */ + +int +TclEvalObjvInternal(interp, objc, objv, command, length, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + char *command; /* Points to the beginning of the string + * representation of the command; this + * is used for traces. If the string + * representation of the command is + * unknown, an empty string should be + * supplied. If it is NULL, no traces will + * be called. */ + int length; /* Number of bytes in command; if -1, all + * characters up to the first null byte are + * used. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ + +{ + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj **newObjv; + int i, code; + Trace *tracePtr, *nextPtr; + char **argv, *commandCopy; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + + Tcl_ResetResult(interp); + if (objc == 0) { + return TCL_OK; + } + + /* + * If the interpreter was deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. + */ + + if (iPtr->numLevels >= iPtr->maxNestingDepth) { + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + return TCL_ERROR; + } + iPtr->numLevels++; + + /* + * On the Mac, we will never reach the default recursion limit before + * blowing the stack. So we need to do a check here. + */ + + if (TclpCheckStackSpace() == 0) { + /*NOTREACHED*/ + iPtr->numLevels--; + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + return TCL_ERROR; + } + + /* + * Find the procedure to execute this command. If there isn't one, + * then see if there is a command "unknown". If so, create a new + * word array with "unknown" as the first word and the original + * command words as arguments. Then call ourselves recursively + * to execute it. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (cmdPtr == NULL) { + newObjv = (Tcl_Obj **) ckalloc((unsigned) + ((objc + 1) * sizeof (Tcl_Obj *))); + for (i = objc-1; i >= 0; i--) { + newObjv[i+1] = objv[i]; + } + newObjv[0] = Tcl_NewStringObj("::unknown", -1); + Tcl_IncrRefCount(newObjv[0]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", Tcl_GetString(objv[0]), "\"", + (char *) NULL); + code = TCL_ERROR; + } else { + code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0); + } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *) newObjv); + goto done; + } + + /* + * Call trace procedures if needed. + */ + + if (command != NULL) { + argv = NULL; + commandCopy = command; + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { + nextPtr = tracePtr->nextPtr; + if (iPtr->numLevels > tracePtr->level) { + continue; + } + + /* + * This is a bit messy because we have to emulate the old trace + * interface, which uses strings for everything. + */ + + if (argv == NULL) { + argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[objc] = 0; + + if (length < 0) { + length = strlen(command); + } else if ((size_t)length < strlen(command)) { + commandCopy = (char *) ckalloc((unsigned) (length + 1)); + strncpy(commandCopy, command, (size_t) length); + commandCopy[length] = 0; + } + } + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + commandCopy, cmdPtr->proc, cmdPtr->clientData, + objc, argv); + } + if (argv != NULL) { + ckfree((char *) argv); + } + if (commandCopy != command) { + ckfree((char *) commandCopy); + } + } + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. + */ + + iPtr->cmdCount++; + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + iPtr->varFramePtr = savedVarFramePtr; + if (Tcl_AsyncReady()) { + code = Tcl_AsyncInvoke(interp, code); + } + + /* + * If the interpreter has a non-empty string result, the result + * object is either empty or stale because some procedure set + * interp->result directly. If so, move the string result to the + * result object, then reset the string result. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + + done: + iPtr->numLevels--; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObjv -- + * + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. + * + * Results: + * 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: + * Depends on the command. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalObjv(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ +{ + Interp *iPtr = (Interp *)interp; + Trace *tracePtr; + Tcl_DString cmdBuf; + char *cmdString = ""; + int cmdLen = 0; + int code = TCL_OK; + + for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { + /* + * EvalObjv will increment numLevels so use "<" rather than "<=" + */ + if (iPtr->numLevels < tracePtr->level) { + int i; + /* + * The command will be needed for an execution trace or stack trace + * generate a command string. + */ + cmdtraced: + Tcl_DStringInit(&cmdBuf); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); + } + cmdString = Tcl_DStringValue(&cmdBuf); + cmdLen = Tcl_DStringLength(&cmdBuf); + break; + } + } + + /* + * Execute the command if we have not done so already + */ + switch (code) { + case TCL_OK: + code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); + if (code == TCL_ERROR && cmdLen == 0) + goto cmdtraced; + break; + case TCL_ERROR: + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + break; + default: + /*NOTREACHED*/ + break; + } + + if (cmdLen != 0) { + Tcl_DStringFree(&cmdBuf); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This procedure is invoked after an error occurs in an interpreter. + * It adds information to the "errorInfo" variable to describe the + * command that was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_LogCommandInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log information. */ + char *script; /* First character in script containing + * command (must be <= command). */ + char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ +{ + char buffer[200]; + register char *p; + char *ellipsis = ""; + Interp *iPtr = (Interp *) interp; + + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this + * command; we shouldn't add anything more. + */ + + return; + } + + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. + */ + + if (length < 0) { + length = strlen(command); + } + if (length > 150) { + length = 150; + ellipsis = "..."; + } + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buffer, "\n while executing\n\"%.*s%s\"", + length, command, ellipsis); + } else { + sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", + length, command, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buffer, -1); + iPtr->flags &= ~ERR_ALREADY_LOGGED; +} + +/* + *---------------------------------------------------------------------- + * + * 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 standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. + * + * Side effects: + * Depends on the array of tokens being evaled. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalTokensStandard(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. */ +{ + Tcl_Obj *resultPtr, *indexPtr, *valuePtr, *newPtr; + 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; + 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)) { + newPtr = Tcl_DuplicateObj(resultPtr); + Tcl_DecrRefCount(resultPtr); + resultPtr = newPtr; + Tcl_IncrRefCount(resultPtr); + } + if (valuePtr != NULL) { + p = Tcl_GetStringFromObj(valuePtr, &length); + } + Tcl_AppendToObj(resultPtr, p, length); + } + } + 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; + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalEx -- + * + * This procedure evaluates a Tcl script without using the compiler + * or byte-code interpreter. It just parses the script, creates + * values for each word of each command, then calls EvalObjv + * to execute each command. + * + * Results: + * 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: + * Depends on the script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalEx(interp, script, numBytes, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * script. Also used for error reporting. */ + char *script; /* First character of script to evaluate. */ + int numBytes; /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ +{ + Interp *iPtr = (Interp *) interp; + char *p, *next; + Tcl_Parse parse; +#define NUM_STATIC_OBJS 20 + Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; + Tcl_Token *tokenPtr; + int i, code, commandLength, bytesLeft, nested; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + + /* + * The variables below keep track of how much state has been + * allocated while evaluating the script, so that it can be freed + * properly if an error occurs. + */ + + int gotParse = 0, objectsUsed = 0; + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + + /* + * Each iteration through the following loop parses the next + * command from the script and then executes it. + */ + + 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) + != TCL_OK) { + code = TCL_ERROR; + goto error; + } + gotParse = 1; + if (parse.numWords > 0) { + /* + * Generate an array of objects for the words of the command. + */ + + if (parse.numWords <= NUM_STATIC_OBJS) { + objv = staticObjArray; + } else { + objv = (Tcl_Obj **) ckalloc((unsigned) + (parse.numWords * sizeof (Tcl_Obj *))); + } + for (objectsUsed = 0, tokenPtr = parse.tokenPtr; + objectsUsed < parse.numWords; + objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { + code = Tcl_EvalTokensStandard(interp, tokenPtr+1, + tokenPtr->numComponents); + if (code == TCL_OK) { + objv[objectsUsed] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objectsUsed]); + } else { + goto error; + } + } + + /* + * Execute the command and free the objects for its words. + */ + + code = TclEvalObjvInternal(interp, objectsUsed, objv, p, bytesLeft, 0); + if (code != TCL_OK) { + goto error; + } + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + objectsUsed = 0; + if (objv != staticObjArray) { + ckfree((char *) objv); + objv = staticObjArray; + } + } + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + Tcl_FreeParse(&parse); + gotParse = 0; + if ((nested != 0) && (p > script) && (p[-1] == ']')) { + /* + * We get here in the special case where the TCL_BRACKET_TERM + * flag was set in the interpreter and we reached a close + * bracket in the script. 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; + + error: + /* + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. + */ + + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + commandLength = parse.commandSize; + if ((parse.commandStart + commandLength) != (script + numBytes)) { + /* + * The command where the error occurred didn't end at the end + * of the script (i.e. it ended at a terminator character such + * as ";". Reduce the length by one so that the error message + * doesn't include the terminator character. + */ + + commandLength -= 1; + } + Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); + } + + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + if (gotParse) { + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + Tcl_FreeParse(&parse); + + if ((nested != 0) && (p > script)) { + char *nextCmd = NULL; /* pointer to start of next command */ + + /* + * We get here in the special case where the TCL_BRACKET_TERM + * flag was set in the interpreter. + * + * At this point, we want to find the end of the script + * (either end of script or the closing ']'). + */ + + while ((p[-1] != ']') && bytesLeft) { + if (Tcl_ParseCommand(NULL, p, bytesLeft, nested, &parse) + != TCL_OK) { + /* + * We were looking for the ']' to close the script. + * But if we find a syntax error, it is ok to quit + * early since in that case we no longer need to know + * where the ']' is (if there was one). We reset the + * pointer to the start of the command that after the + * one causing the return. -- hobbs + */ + + p = (nextCmd == NULL) ? parse.commandStart : nextCmd; + break; + } + + if (nextCmd == NULL) { + nextCmd = parse.commandStart; + } + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + Tcl_FreeParse(&parse); + } + iPtr->termOffset = (p - 1) - script; + } else { + iPtr->termOffset = p - script; + } + } + if (objv != staticObjArray) { + ckfree((char *) objv); + } + iPtr->varFramePtr = savedVarFramePtr; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Execute a Tcl command in a string. This procedure executes the + * script directly, rather than compiling it to bytecodes. Before + * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was + * the main procedure used for executing Tcl commands, but nowadays + * it isn't used much. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and interp's result contains a value + * to supplement the return code. The value of the result + * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: + * you must copy it or lose it! + * + * Side effects: + * Can be almost arbitrary, depending on the commands in the script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eval(interp, string) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + char *string; /* Pointer to TCL command to execute. */ +{ + int code; + + code = Tcl_EvalEx(interp, string, -1, 0); + + /* + * For backwards compatibility with old C code that predates the + * object system in Tcl 8.0, we have to mirror the object result + * back into the string result (some callers may expect it there). + */ + + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObj, Tcl_GlobalEvalObj -- + * + * These functions are deprecated but we keep them around for backwards + * compatibility reasons. + * + * Results: + * See the functions they call. + * + * Side effects: + * See the functions they call. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_EvalObj +int +Tcl_EvalObj(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; +{ + return Tcl_EvalObjEx(interp, objPtr, 0); +} + +#undef Tcl_GlobalEvalObj +int +Tcl_GlobalEvalObj(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; +{ + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are diff --git a/generic/tclParse.c b/generic/tclParse.c index f19e4e4..ae53606 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -4,9 +4,7 @@ * This file contains procedures that parse Tcl scripts. They * do so in a general-purpose fashion that can be used for many * different purposes, including compilation, direct execution, - * code analysis, etc. This file also includes a few additional - * procedures such as Tcl_EvalObjv, Tcl_Eval, and Tcl_EvalEx, which - * allow scripts to be evaluated directly, without compiling. + * code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. @@ -14,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: tclParse.c,v 1.17 2001/11/16 20:01:04 msofer Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.18 2001/11/19 17:30:27 msofer Exp $ */ #include "tclInt.h" @@ -752,907 +750,6 @@ TclExpandTokenArray(parsePtr) /* *---------------------------------------------------------------------- * - * TclEvalObjvInternal -- - * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. - * - * Results: - * 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. If an error occurs, this procedure does - * NOT add any information to the errorInfo variable. - * - * Side effects: - * Depends on the command. - * - *---------------------------------------------------------------------- - */ - -int -TclEvalObjvInternal(interp, objc, objv, command, length, flags) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ - int objc; /* Number of words in command. */ - Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are - * the words that make up the command. */ - char *command; /* Points to the beginning of the string - * representation of the command; this - * is used for traces. If the string - * representation of the command is - * unknown, an empty string should be - * supplied. If it is NULL, no traces will - * be called. */ - int length; /* Number of bytes in command; if -1, all - * characters up to the first null byte are - * used. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ - -{ - Command *cmdPtr; - Interp *iPtr = (Interp *) interp; - Tcl_Obj **newObjv; - int i, code; - Trace *tracePtr, *nextPtr; - char **argv, *commandCopy; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ - - Tcl_ResetResult(interp); - if (objc == 0) { - return TCL_OK; - } - - /* - * If the interpreter was deleted, return an error. - */ - - if (iPtr->flags & DELETED) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "attempt to call eval in deleted interpreter", -1); - Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", - (char *) NULL); - return TCL_ERROR; - } - - /* - * Check depth of nested calls to Tcl_Eval: if this gets too large, - * it's probably because of an infinite loop somewhere. - */ - - if (iPtr->numLevels >= iPtr->maxNestingDepth) { - iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; - return TCL_ERROR; - } - iPtr->numLevels++; - - /* - * On the Mac, we will never reach the default recursion limit before - * blowing the stack. So we need to do a check here. - */ - - if (TclpCheckStackSpace() == 0) { - /*NOTREACHED*/ - iPtr->numLevels--; - iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; - return TCL_ERROR; - } - - /* - * Find the procedure to execute this command. If there isn't one, - * then see if there is a command "unknown". If so, create a new - * word array with "unknown" as the first word and the original - * command words as arguments. Then call ourselves recursively - * to execute it. - */ - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) ckalloc((unsigned) - ((objc + 1) * sizeof (Tcl_Obj *))); - for (i = objc-1; i >= 0; i--) { - newObjv[i+1] = objv[i]; - } - newObjv[0] = Tcl_NewStringObj("::unknown", -1); - Tcl_IncrRefCount(newObjv[0]); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", Tcl_GetString(objv[0]), "\"", - (char *) NULL); - code = TCL_ERROR; - } else { - code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0); - } - Tcl_DecrRefCount(newObjv[0]); - ckfree((char *) newObjv); - goto done; - } - - /* - * Call trace procedures if needed. - */ - - if (command != NULL) { - argv = NULL; - commandCopy = command; - - for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { - nextPtr = tracePtr->nextPtr; - if (iPtr->numLevels > tracePtr->level) { - continue; - } - - /* - * This is a bit messy because we have to emulate the old trace - * interface, which uses strings for everything. - */ - - if (argv == NULL) { - argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - argv[objc] = 0; - - if (length < 0) { - length = strlen(command); - } else if ((size_t)length < strlen(command)) { - commandCopy = (char *) ckalloc((unsigned) (length + 1)); - strncpy(commandCopy, command, (size_t) length); - commandCopy[length] = 0; - } - } - (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, - commandCopy, cmdPtr->proc, cmdPtr->clientData, - objc, argv); - } - if (argv != NULL) { - ckfree((char *) argv); - } - if (commandCopy != command) { - ckfree((char *) commandCopy); - } - } - - /* - * Finally, invoke the command's Tcl_ObjCmdProc. - */ - - iPtr->cmdCount++; - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; - } - code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); - iPtr->varFramePtr = savedVarFramePtr; - if (Tcl_AsyncReady()) { - code = Tcl_AsyncInvoke(interp, code); - } - - /* - * If the interpreter has a non-empty string result, the result - * object is either empty or stale because some procedure set - * interp->result directly. If so, move the string result to the - * result object, then reset the string result. - */ - - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } - - done: - iPtr->numLevels--; - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObjv -- - * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. - * - * Results: - * 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: - * Depends on the command. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EvalObjv(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ - int objc; /* Number of words in command. */ - Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are - * the words that make up the command. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ -{ - Interp *iPtr = (Interp *)interp; - Trace *tracePtr; - Tcl_DString cmdBuf; - char *cmdString = ""; - int cmdLen = 0; - int code = TCL_OK; - - for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { - /* - * EvalObjv will increment numLevels so use "<" rather than "<=" - */ - if (iPtr->numLevels < tracePtr->level) { - int i; - /* - * The command will be needed for an execution trace or stack trace - * generate a command string. - */ - cmdtraced: - Tcl_DStringInit(&cmdBuf); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); - } - cmdString = Tcl_DStringValue(&cmdBuf); - cmdLen = Tcl_DStringLength(&cmdBuf); - break; - } - } - - /* - * Execute the command if we have not done so already - */ - switch (code) { - case TCL_OK: - code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); - if (code == TCL_ERROR && cmdLen == 0) - goto cmdtraced; - break; - case TCL_ERROR: - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - break; - default: - /*NOTREACHED*/ - break; - } - - if (cmdLen != 0) { - Tcl_DStringFree(&cmdBuf); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LogCommandInfo -- - * - * This procedure is invoked after an error occurs in an interpreter. - * It adds information to the "errorInfo" variable to describe the - * command that was being executed when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Information about the command is added to errorInfo and the - * line number stored internally in the interpreter is set. If this - * is the first call to this procedure or Tcl_AddObjErrorInfo since - * an error occurred, then old information in errorInfo is - * deleted. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_LogCommandInfo(interp, script, command, length) - Tcl_Interp *interp; /* Interpreter in which to log information. */ - char *script; /* First character in script containing - * command (must be <= command). */ - char *command; /* First character in command that - * generated the error. */ - int length; /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ -{ - char buffer[200]; - register char *p; - char *ellipsis = ""; - Interp *iPtr = (Interp *) interp; - - if (iPtr->flags & ERR_ALREADY_LOGGED) { - /* - * Someone else has already logged error information for this - * command; we shouldn't add anything more. - */ - - return; - } - - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - /* - * Create an error message to add to errorInfo, including up to a - * maximum number of characters of the command. - */ - - if (length < 0) { - length = strlen(command); - } - if (length > 150) { - length = 150; - ellipsis = "..."; - } - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buffer, "\n while executing\n\"%.*s%s\"", - length, command, ellipsis); - } else { - sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", - length, command, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buffer, -1); - iPtr->flags &= ~ERR_ALREADY_LOGGED; -} - -/* - *---------------------------------------------------------------------- - * - * 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 standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. - * - * Side effects: - * Depends on the array of tokens being evaled. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EvalTokensStandard(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. */ -{ - Tcl_Obj *resultPtr, *indexPtr, *valuePtr, *newPtr; - 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; - 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)) { - newPtr = Tcl_DuplicateObj(resultPtr); - Tcl_DecrRefCount(resultPtr); - resultPtr = newPtr; - Tcl_IncrRefCount(resultPtr); - } - if (valuePtr != NULL) { - p = Tcl_GetStringFromObj(valuePtr, &length); - } - Tcl_AppendToObj(resultPtr, p, length); - } - } - 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; - } -} - - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalEx -- - * - * This procedure evaluates a Tcl script without using the compiler - * or byte-code interpreter. It just parses the script, creates - * values for each word of each command, then calls EvalObjv - * to execute each command. - * - * Results: - * 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: - * Depends on the script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EvalEx(interp, script, numBytes, flags) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * script. Also used for error reporting. */ - char *script; /* First character of script to evaluate. */ - int numBytes; /* Number of bytes in script. If < 0, the - * script consists of all bytes up to the - * first null character. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ -{ - Interp *iPtr = (Interp *) interp; - char *p, *next; - Tcl_Parse parse; -#define NUM_STATIC_OBJS 20 - Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; - Tcl_Token *tokenPtr; - int i, code, commandLength, bytesLeft, nested; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ - - /* - * The variables below keep track of how much state has been - * allocated while evaluating the script, so that it can be freed - * properly if an error occurs. - */ - - int gotParse = 0, objectsUsed = 0; - - if (numBytes < 0) { - numBytes = strlen(script); - } - Tcl_ResetResult(interp); - - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; - } - - /* - * Each iteration through the following loop parses the next - * command from the script and then executes it. - */ - - 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) - != TCL_OK) { - code = TCL_ERROR; - goto error; - } - gotParse = 1; - if (parse.numWords > 0) { - /* - * Generate an array of objects for the words of the command. - */ - - if (parse.numWords <= NUM_STATIC_OBJS) { - objv = staticObjArray; - } else { - objv = (Tcl_Obj **) ckalloc((unsigned) - (parse.numWords * sizeof (Tcl_Obj *))); - } - for (objectsUsed = 0, tokenPtr = parse.tokenPtr; - objectsUsed < parse.numWords; - objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { - code = Tcl_EvalTokensStandard(interp, tokenPtr+1, - tokenPtr->numComponents); - if (code == TCL_OK) { - objv[objectsUsed] = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(objv[objectsUsed]); - } else { - goto error; - } - } - - /* - * Execute the command and free the objects for its words. - */ - - code = TclEvalObjvInternal(interp, objectsUsed, objv, p, bytesLeft, 0); - if (code != TCL_OK) { - goto error; - } - for (i = 0; i < objectsUsed; i++) { - Tcl_DecrRefCount(objv[i]); - } - objectsUsed = 0; - if (objv != staticObjArray) { - ckfree((char *) objv); - objv = staticObjArray; - } - } - - /* - * Advance to the next command in the script. - */ - - next = parse.commandStart + parse.commandSize; - bytesLeft -= next - p; - p = next; - Tcl_FreeParse(&parse); - gotParse = 0; - if ((nested != 0) && (p > script) && (p[-1] == ']')) { - /* - * We get here in the special case where the TCL_BRACKET_TERM - * flag was set in the interpreter and we reached a close - * bracket in the script. 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; - - error: - /* - * Generate various pieces of error information, such as the line - * number where the error occurred and information to add to the - * errorInfo variable. Then free resources that had been allocated - * to the command. - */ - - if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - commandLength = parse.commandSize; - if ((parse.commandStart + commandLength) != (script + numBytes)) { - /* - * The command where the error occurred didn't end at the end - * of the script (i.e. it ended at a terminator character such - * as ";". Reduce the length by one so that the error message - * doesn't include the terminator character. - */ - - commandLength -= 1; - } - Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); - } - - for (i = 0; i < objectsUsed; i++) { - Tcl_DecrRefCount(objv[i]); - } - if (gotParse) { - next = parse.commandStart + parse.commandSize; - bytesLeft -= next - p; - p = next; - Tcl_FreeParse(&parse); - - if ((nested != 0) && (p > script)) { - char *nextCmd = NULL; /* pointer to start of next command */ - - /* - * We get here in the special case where the TCL_BRACKET_TERM - * flag was set in the interpreter. - * - * At this point, we want to find the end of the script - * (either end of script or the closing ']'). - */ - - while ((p[-1] != ']') && bytesLeft) { - if (Tcl_ParseCommand(NULL, p, bytesLeft, nested, &parse) - != TCL_OK) { - /* - * We were looking for the ']' to close the script. - * But if we find a syntax error, it is ok to quit - * early since in that case we no longer need to know - * where the ']' is (if there was one). We reset the - * pointer to the start of the command that after the - * one causing the return. -- hobbs - */ - - p = (nextCmd == NULL) ? parse.commandStart : nextCmd; - break; - } - - if (nextCmd == NULL) { - nextCmd = parse.commandStart; - } - - /* - * Advance to the next command in the script. - */ - - next = parse.commandStart + parse.commandSize; - bytesLeft -= next - p; - p = next; - Tcl_FreeParse(&parse); - } - iPtr->termOffset = (p - 1) - script; - } else { - iPtr->termOffset = p - script; - } - } - if (objv != staticObjArray) { - ckfree((char *) objv); - } - iPtr->varFramePtr = savedVarFramePtr; - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Eval -- - * - * Execute a Tcl command in a string. This procedure executes the - * script directly, rather than compiling it to bytecodes. Before - * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was - * the main procedure used for executing Tcl commands, but nowadays - * it isn't used much. - * - * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp's result contains a value - * to supplement the return code. The value of the result - * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: - * you must copy it or lose it! - * - * Side effects: - * Can be almost arbitrary, depending on the commands in the script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Eval(interp, string) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ - char *string; /* Pointer to TCL command to execute. */ -{ - int code; - - code = Tcl_EvalEx(interp, string, -1, 0); - - /* - * For backwards compatibility with old C code that predates the - * object system in Tcl 8.0, we have to mirror the object result - * back into the string result (some callers may expect it there). - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObj, Tcl_GlobalEvalObj -- - * - * These functions are deprecated but we keep them around for backwards - * compatibility reasons. - * - * Results: - * See the functions they call. - * - * Side effects: - * See the functions they call. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_EvalObj -int -Tcl_EvalObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; -{ - return Tcl_EvalObjEx(interp, objPtr, 0); -} - -#undef Tcl_GlobalEvalObj -int -Tcl_GlobalEvalObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; -{ - return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_ParseVarName -- * * Given a string starting with a $ sign, parse off a variable |