通讯编程

开发平台：

Visual C++

tclBasic.c：源码内容

* currently supported. */
{
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
Tcl_Obj **newObjv;
int i;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int code = TCL_OK;
int traceCode = TCL_OK;
int checkTraces = 1;
Namespace *savedNsPtr = NULL;
if (TclInterpReady(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (objc == 0) {
return TCL_OK;
}
/*
* If any execution traces rename or delete the current command,
* we may need (at most) two passes here.
*/
savedVarFramePtr = iPtr->varFramePtr;
while (1) {
/* Configure evaluation context to match the requested flags */
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
} else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) {
savedNsPtr = iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr;
}
/*
* 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 {
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc+1, newObjv,
command, length, 0);
iPtr->numLevels--;
}
Tcl_DecrRefCount(newObjv[0]);
ckfree((char *) newObjv);
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
goto done;
}
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
/*
* Call trace procedures if needed.
*/
if ((checkTraces) && (command != NULL)) {
int cmdEpoch = cmdPtr->cmdEpoch;
int newEpoch;
cmdPtr->refCount++;
/*
* If the first set of traces modifies/deletes the command or
* any existing traces, then the set checkTraces to 0 and
* go through this while loop one more time.
*/
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& (traceCode == TCL_OK)) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
newEpoch = cmdPtr->cmdEpoch;
TclCleanupCommand(cmdPtr);
if (cmdEpoch != newEpoch) {
/* The command has been modified in some way */
checkTraces = 0;
continue;
}
}
break;
}
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
char *a[10];
int i = 0;
while (i < 10) {
a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
}
TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
/*
* Finally, invoke the command's Tcl_ObjCmdProc.
*/
cmdPtr->refCount++;
iPtr->cmdCount++;
if ( code == TCL_OK && traceCode == TCL_OK) {
if (TCL_DTRACE_CMD_ENTRY_ENABLED()) {
TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
(Tcl_Obj **)(objv + 1));
}
code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
if (TCL_DTRACE_CMD_RETURN_ENABLED()) {
TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code);
}
}
if (Tcl_AsyncReady()) {
code = Tcl_AsyncInvoke(interp, code);
}
/*
* Call 'leave' command traces
*/
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
int saveErrFlags = iPtr->flags
& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
traceCode = TclCheckExecutionTraces (interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (traceCode == TCL_OK) {
iPtr->flags |= saveErrFlags;
}
}
TclCleanupCommand(cmdPtr);
/*
* If one of the trace invocation resulted in error, then
* change the result code accordingly. Note, that the
* interp->result should already be set correctly by the
* call to TraceExecutionProc.
*/
if (traceCode != TCL_OK) {
code = traceCode;
}
/*
* 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);
}
if (TCL_DTRACE_CMD_RESULT_ENABLED()) {
Tcl_Obj *r;
r = Tcl_GetObjResult(interp);
TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r), r);
}
done:
iPtr->varFramePtr = savedVarFramePtr;
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 and TCL_EVAL_INVOKE
* are currently supported. */
{
Interp *iPtr = (Interp *)interp;
Trace *tracePtr;
Tcl_DString cmdBuf;
char *cmdString = ""; /* A command string is only necessary for
* command traces or error logs; it will be
* generated to replace this default value if
* necessary. */
int cmdLen = 0; /* a non-zero value indicates that a command
* string was generated. */
int code = TCL_OK;
int i;
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {
/*
* The command may be needed for an execution trace. Generate a
* command string.
*/
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;
}
}
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
iPtr->numLevels--;
/*
* If we are again at the top level, process any unusual
* return code returned by the evaluated code.
*/
if (iPtr->numLevels == 0) {
if (code == TCL_RETURN) {
code = TclUpdateReturnInfo(iPtr);
}
if ((code != TCL_OK) && (code != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, code);
code = TCL_ERROR;
}
}
if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
/*
* If there was an error, a command string will be needed for the
* error log: generate it now if it was not done previously.
*/
if (cmdLen == 0) {
Tcl_DStringInit(&cmdBuf);
for (i = 0; i < objc; i++) {
Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
}
cmdString = Tcl_DStringValue(&cmdBuf);
cmdLen = Tcl_DStringLength(&cmdBuf);
}
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
}
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. */
CONST char *script; /* First character in script containing
* command (must be <= command). */
CONST 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 CONST 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 = "...";
}
while ( (command[length] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate in the
* middle of a multi-byte character (in UTF-8)
*/
length--;
ellipsis = "...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buffer, "n while executingn"%.*s%s"",
length, command, ellipsis);
} else {
sprintf(buffer, "n invoked from withinn"%.*s%s"",
length, command, ellipsis);
}
Tcl_AddObjErrorInfo(interp, buffer, -1);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalTokensStandard, 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.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
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. */
{
#ifdef TCL_TIP280
return EvalTokensStandard (interp, tokenPtr, count, 1);
}
static int
EvalTokensStandard(interp, tokenPtr, count, line)
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 line; /* The line the script starts on. */
{
#endif
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: {
Interp *iPtr = (Interp *) interp;
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
#ifndef TCL_TIP280
code = Tcl_EvalEx(interp,
tokenPtr->start+1, tokenPtr->size-2, 0);
#else
/* TIP #280: Transfer line information to nested command */
code = EvalEx(interp,
tokenPtr->start+1, tokenPtr->size-2, 0, line);
#endif
}
iPtr->numLevels--;
if (code != TCL_OK) {
goto done;
}
valuePtr = Tcl_GetObjResult(interp);
break;
}
case TCL_TOKEN_VARIABLE:
if (tokenPtr->numComponents == 1) {
indexPtr = NULL;
index = NULL;
} else {
#ifndef TCL_TIP280
code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
tokenPtr->numComponents - 1);
#else
/* TIP #280: Transfer line information to nested command */
code = EvalTokensStandard(interp, tokenPtr+2,
tokenPtr->numComponents - 1, line);
#endif
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;
}
/*
*----------------------------------------------------------------------
*
* 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, 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.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalEx(interp, script, numBytes, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
CONST 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. */
{
#ifdef TCL_TIP280
return EvalEx (interp, script, numBytes, flags, 1);
}
static int
EvalEx(interp, script, numBytes, flags, line)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
CONST 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. */
int line; /* The line the script starts on. */
{
#endif
Interp *iPtr = (Interp *) interp;
CONST char *p, *next;
Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
Tcl_Token *tokenPtr;
int code = TCL_OK;
int i, commandLength, bytesLeft, nested;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
/*
* 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;
#ifdef TCL_TIP280
/* TIP #280 Structures for tracking of command locations. */
CmdFrame eeFrame;
#endif
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;
}
#ifdef TCL_TIP280
/* TIP #280 Initialize tracking. Do not push on the frame stack yet. */
/*
* We may cont. counting based on a specific context (CTX), or open a new
* context, either for a sourced script, or 'eval'. For sourced files we
* always have a path object, even if nothing was specified in the interp
* itself. That makes code using it simpler as NULL checks can be left
* out. Sourced file without path in the 'scriptFile' is possible during
* Tcl initialization.
*/
if (iPtr->evalFlags & TCL_EVAL_CTX) {
/* Path information comes out of the context. */
eeFrame.type = TCL_LOCATION_SOURCE;
eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path;
Tcl_IncrRefCount (eeFrame.data.eval.path);
} else if (iPtr->evalFlags & TCL_EVAL_FILE) {
/* Set up for a sourced file */
eeFrame.type = TCL_LOCATION_SOURCE;
if (iPtr->scriptFile) {
/* Normalization here, to have the correct pwd. Should have
* negligible impact on performance, as the norm should have been
* done already by the 'source' invoking us, and it caches the
* result
*/
Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile);
if (!norm) {
/* Error message in the interp result */
return TCL_ERROR;
}
eeFrame.data.eval.path = norm;
Tcl_IncrRefCount (eeFrame.data.eval.path);
} else {
eeFrame.data.eval.path = Tcl_NewStringObj ("",-1);
}
} else {
/* Set up for plain eval */
eeFrame.type = TCL_LOCATION_EVAL;
eeFrame.data.eval.path = NULL;
}
eeFrame.level = (iPtr->cmdFramePtr == NULL
? 1
: iPtr->cmdFramePtr->level + 1);
eeFrame.framePtr = iPtr->framePtr;
eeFrame.nextPtr = iPtr->cmdFramePtr;
eeFrame.nline = 0;
eeFrame.line = NULL;
#endif
iPtr->evalFlags = 0;
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &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;
}
#ifdef TCL_TIP280
/*
* TIP #280 Track lines. The parser may have skipped text till it
* found the command we are now at. We have count the lines in this
* block.
*/
TclAdvanceLines (&line, p, parse.commandStart);
#endif
if (parse.numWords > 0) {
#ifdef TCL_TIP280
/*
* TIP #280. Track lines within the words of the current
* command.
*/
int wordLine = line;
CONST char* wordStart = parse.commandStart;
#endif
/*
* 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 *)));
}
#ifdef TCL_TIP280
eeFrame.nline = parse.numWords;
eeFrame.line = (int*) ckalloc((unsigned)
(parse.numWords * sizeof (int)));
#endif
for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
objectsUsed < parse.numWords;
objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
#ifndef TCL_TIP280
code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
tokenPtr->numComponents);
#else
/*
* TIP #280. Track lines to current word. Save the
* information on a per-word basis, signaling dynamic words as
* needed. Make the information available to the recursively
* called evaluator as well, including the type of context
* (source vs. eval).
*/
TclAdvanceLines (&wordLine, wordStart, tokenPtr->start);
wordStart = tokenPtr->start;
eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr)
? wordLine
: -1);
if (eeFrame.type == TCL_LOCATION_SOURCE) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
code = EvalTokensStandard(interp, tokenPtr+1,
tokenPtr->numComponents, wordLine);
iPtr->evalFlags = 0;
#endif
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.
*
* TIP #280: Remember the command itself for 'info frame'. We
* shorten the visible command by one char to exclude the
* termination character, if necessary. Here is where we put our
* frame on the stack of frames too. _After_ the nested commands
* have been executed.
*/
#ifdef TCL_TIP280
eeFrame.cmd.str.cmd = parse.commandStart;
eeFrame.cmd.str.len = parse.commandSize;
if (parse.term == parse.commandStart + parse.commandSize - 1) {
eeFrame.cmd.str.len --;
}
iPtr->cmdFramePtr = &eeFrame;
#endif
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objectsUsed, objv,
parse.commandStart, parse.commandSize, 0);
iPtr->numLevels--;
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
ckfree ((char*) eeFrame.line);
eeFrame.line = NULL;
eeFrame.nline = 0;
#endif
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.
*
* TIP #280 Track Lines. Now we track how many lines were in the
* executed command.
*/
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
#ifdef TCL_TIP280
TclAdvanceLines (&line, parse.commandStart, p);
#endif
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;
#ifndef TCL_TIP280
return TCL_OK;
#else
code = TCL_OK;
goto cleanup_return;
#endif
}
} while (bytesLeft > 0);
if (nested) {
/*
* This nested script did not terminate in ']', it is an error.
*/
code = TCL_ERROR;
goto error;
}
iPtr->termOffset = p - script;
iPtr->varFramePtr = savedVarFramePtr;
#ifndef TCL_TIP280
return TCL_OK;
#else
code = TCL_OK;
goto cleanup_return;
#endif
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 (iPtr->numLevels == 0) {
if (code == TCL_RETURN) {
code = TclUpdateReturnInfo(iPtr);
}
if ((code != TCL_OK) && (code != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, code);
code = TCL_ERROR;
}
}
if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
commandLength = parse.commandSize;
if (parse.term == parse.commandStart + commandLength - 1) {
/*
* The terminator character (such as ; or ]) of the command where
* the error occurred is the last character in the parsed command.
* 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) {
Tcl_FreeParse(&parse);
}
if (objv != staticObjArray) {
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;
#ifndef TCL_TIP280
return code;
#else
goto cleanup_return;
#endif
}
/*
* 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;
}
#ifndef TCL_TIP280
return code;
#else
goto cleanup_return;
#endif
}
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));
#ifndef TCL_TIP280
return TCL_ERROR;
#else
code = TCL_ERROR;
goto cleanup_return;
#endif
} 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));
#ifndef TCL_TIP280
return TCL_ERROR;
#else
code = TCL_ERROR;
goto cleanup_return;
#endif
} else {
/*
* parse.term points to the close-bracket.
*/
iPtr->termOffset = parse.term - script;
}
#ifdef TCL_TIP280
cleanup_return:
/* TIP #280. Release the local CmdFrame, and its contents. */
if (eeFrame.line != NULL) {
ckfree ((char*) eeFrame.line);
}
if (eeFrame.type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eeFrame.data.eval.path);
}
#endif
return code;
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* TclAdvanceLines --
*
* This procedure is a helper which counts the number of lines
* in a block of text and advances an external counter.
*
* Results:
* None.
*
* Side effects:
* The specified counter is advanced per the number of lines found.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclAdvanceLines (line,start,end)
int* line;
CONST char* start;
CONST char* end;
{
CONST char* p;
for (p = start; p < end; p++) {
if (*p == 'n') {
(*line) ++;
}
}
}
#endif
/*
*----------------------------------------------------------------------
*
* 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). */
CONST char *string; /* Pointer to TCL command to execute. */
{
int 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, TclEvalObjEx --
*
* Execute Tcl commands stored in a Tcl object. These commands are
* compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
* is specified.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and the interpreter's result contains a value
* to supplement the return code.
*
* Side effects:
* The object is converted, if necessary, to a ByteCode object that
* 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.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjEx(interp, objPtr, flags)
Tcl_Interp *interp; /* Token for command interpreter
* (returned by a previous call to
* Tcl_CreateInterp). */
register Tcl_Obj *objPtr; /* Pointer to object containing
* commands to execute. */
int flags; /* Collection of OR-ed bits that
* control the evaluation of the
* script. Supported values are
* TCL_EVAL_GLOBAL and
* TCL_EVAL_DIRECT. */
{
#ifdef TCL_TIP280
return TclEvalObjEx (interp, objPtr, flags, NULL, 0);
}
int
TclEvalObjEx(interp, objPtr, flags, invoker, word)
Tcl_Interp *interp; /* Token for command interpreter
* (returned by a previous call to
* Tcl_CreateInterp). */
register Tcl_Obj *objPtr; /* Pointer to object containing
* commands to execute. */
int flags; /* Collection of OR-ed bits that
* control the evaluation of the
* script. Supported values are
* TCL_EVAL_GLOBAL and
* TCL_EVAL_DIRECT. */
CONST CmdFrame* invoker; /* Frame of the command doing the eval */
int word; /* Index of the word which is in objPtr */
{
#endif
register Interp *iPtr = (Interp *) interp;
char *script;
int numSrcBytes;
int result;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
Tcl_IncrRefCount(objPtr);
if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
/*
* We're not supposed to use the compiler or byte-code interpreter.
* Let Tcl_EvalEx evaluate the command directly (and probably
* more slowly).
*
* Pure List Optimization (no string representation). In this
* case, we can safely use Tcl_EvalObjv instead and get an
* appreciable improvement in execution speed. This is because it
* allows us to avoid a setFromAny step that would just pack
* everything into a string and back out again.
*
* USE_EVAL_DIRECT is a special flag used for testing purpose only
* (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
*/
if (!(iPtr->flags & USE_EVAL_DIRECT) &&
(objPtr->typePtr == &tclListType) && /* is a list... */
(objPtr->bytes == NULL) /* ...without a string rep */) {
register List *listRepPtr =
(List *) objPtr->internalRep.twoPtrValue.ptr1;
int i, objc = listRepPtr->elemCount;
#define TEOE_PREALLOC 10
Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv;
#ifdef TCL_TIP280
/* TIP #280 Structures for tracking lines.
* As we know that this is dynamic execution we ignore the
* invoker, even if known.
*/
int line;
CmdFrame eoFrame;
eoFrame.type = TCL_LOCATION_EVAL_LIST;
eoFrame.level = (iPtr->cmdFramePtr == NULL ?
1 :
iPtr->cmdFramePtr->level + 1);
eoFrame.framePtr = iPtr->framePtr;
eoFrame.nextPtr = iPtr->cmdFramePtr;
eoFrame.nline = objc;
eoFrame.line = (int*) ckalloc (objc * sizeof (int));
/* NOTE: Getting the string rep of the list to eval to fill the
* command information required by 'info frame' implies that
* further calls for the same list would not be optimized, as it
* would not be 'pure' anymore. It would also be a waste of time
* as most of the time this information is not needed at all. What
* we do instead is to keep the list obj itself around and have
* 'info frame' sort it out.
*/
eoFrame.cmd.listPtr = objPtr;
Tcl_IncrRefCount (eoFrame.cmd.listPtr);
eoFrame.data.eval.path = NULL;
#endif
if (objc > TEOE_PREALLOC) {
objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *));
}
#undef TEOE_PREALLOC
/*
* Copy the list elements here, to avoid a segfault if
* objPtr loses its List internal rep [Bug 1119369].
*
* TIP #280 Computes all the line numbers for the
* words in the command.
*/
#ifdef TCL_TIP280
line = 1;
#endif
for (i=0; i < objc; i++) {
objv[i] = listRepPtr->elements[i];
Tcl_IncrRefCount(objv[i]);
#ifdef TCL_TIP280
eoFrame.line [i] = line;
{
char* w = Tcl_GetString (objv [i]);
TclAdvanceLines (&line, w, w+ strlen(w));
}
#endif
}
#ifdef TCL_TIP280
iPtr->cmdFramePtr = &eoFrame;
#endif
result = Tcl_EvalObjv(interp, objc, objv, flags);
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
Tcl_DecrRefCount (eoFrame.cmd.listPtr);
#endif
for (i=0; i < objc; i++) {
TclDecrRefCount(objv[i]);
}
if (objv != staticObjv) {
ckfree((char *) objv);
}
#ifdef TCL_TIP280
ckfree ((char*) eoFrame.line);
eoFrame.line = NULL;
eoFrame.nline = 0;
#endif
} else {
#ifndef TCL_TIP280
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
#else
/*
* TIP #280. Propagate context as much as we can. Especially if
* the script to evaluate is a single literal it makes sense to
* look if our context is one with absolute line numbers we can
* then track into the literal itself too.
*
* See also tclCompile.c, TclInitCompileEnv, for the equivalent
* code in the bytecode compiler.
*/
if (invoker == NULL) {
/* No context, force opening of our own */
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
} else {
/* We have an invoker, describing the command asking for the
* evaluation of a subordinate script. This script may
* originate in a literal word, or from a variable, etc. Using
* the line array we now check if we have good line
* information for the relevant word. The type of context is
* relevant as well. In a non-'source' context we don't have
* to try tracking lines.
*
* First see if the word exists and is a literal. If not we go
* through the easy dynamic branch. No need to perform more
* complex invokations.
*/
if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
/* Dynamic script, or dynamic context, force our own
* context */
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
} else {
/* Try to get an absolute context for the evaluation
*/
CmdFrame ctx = *invoker;
int pc = 0;
if (invoker->type == TCL_LOCATION_BC) {
/* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&ctx);
pc = 1;
}
if (ctx.type == TCL_LOCATION_SOURCE) {
/* Absolute context to reuse. */
iPtr->invokeCmdFramePtr = &ctx;
iPtr->evalFlags |= TCL_EVAL_CTX;
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]);
if (pc) {
/* Death of SrcInfo reference */
Tcl_DecrRefCount (ctx.data.eval.path);
}
} else {
/* Dynamic context or script, easier to make our own as
* well */
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
}
}
}
#endif
}
} else {
/*
* Let the compiler/engine subsystem do the evaluation.
*
* TIP #280 The invoker provides us with the context for the
* script. We transfer this to the byte code compiler.
*/
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
}
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, objPtr);
#else
result = TclCompEvalObj(interp, objPtr, invoker, word);
#endif
/*
* If we are again at the top level, process any unusual
* return code returned by the evaluated code.
*/
if (iPtr->numLevels == 0) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
/*
* If an error was created here, record information about
* what was being executed when the error occurred. Remove
* the extra n added by tclMain.c in the command sent to
* Tcl_LogCommandInfo [Bug 833150].
*/
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, --numSrcBytes);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
}
}
iPtr->evalFlags = 0;
iPtr->varFramePtr = savedVarFramePtr;
}
TclDecrRefCount(objPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* ProcessUnexpectedResult --
*
* Procedure called by Tcl_EvalObj to set the interpreter's result
* value to an appropriate error message when the code it evaluates
* returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
* the topmost evaluation level.
*
* Results:
* None.
*
* Side effects:
* The interpreter result is set to an error message appropriate to
* the result code.
*
*----------------------------------------------------------------------
*/
static void
ProcessUnexpectedResult(interp, returnCode)
Tcl_Interp *interp; /* The interpreter in which the unexpected
* result code was returned. */
int returnCode; /* The unexpected result code. */
{
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked "break" outside of a loop", -1);
} else if (returnCode == TCL_CONTINUE) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked "continue" outside of a loop", -1);
} else {
char buf[30 + TCL_INTEGER_SPACE];
sprintf(buf, "command returned bad code: %d", returnCode);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
*
* Procedures to evaluate an expression and return its value in a
* particular form.
*
* Results:
* Each of the procedures below returns a standard Tcl result. If an
* error occurs then an error message is left in the interp's result.
* Otherwise the value of the expression, in the appropriate form,
* is stored at *ptr. If the expression had a result that was
* incompatible with the desired form then an error is returned.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_ExprLong(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
long *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
int result = TCL_OK;
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store an integer based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (long) resultPtr->internalRep.doubleValue;
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
/*
* See Tcl_GetIntFromObj for conversion comments.
*/
Tcl_WideInt w = resultPtr->internalRep.wideValue;
if ((w >= -(Tcl_WideInt)(ULONG_MAX))
&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
*ptr = Tcl_WideAsLong(w);
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
#else
*ptr = resultPtr->internalRep.longValue;
#endif
} else {
Tcl_SetResult(interp,
"expression didn't have numeric value", TCL_STATIC);
result = TCL_ERROR;
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the result integer to 0.
*/
*ptr = 0;
}
return result;
}
int
Tcl_ExprDouble(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
double *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
int result = TCL_OK;
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a double based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = (double) resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = resultPtr->internalRep.doubleValue;
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
/*
* See Tcl_GetIntFromObj for conversion comments.
*/
Tcl_WideInt w = resultPtr->internalRep.wideValue;
if ((w >= -(Tcl_WideInt)(ULONG_MAX))
&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
*ptr = (double) Tcl_WideAsLong(w);
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
#else
*ptr = (double) resultPtr->internalRep.longValue;
#endif
} else {
Tcl_SetResult(interp,
"expression didn't have numeric value", TCL_STATIC);
result = TCL_ERROR;
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the result double to 0.0.
*/
*ptr = 0.0;
}
return result;
}
int
Tcl_ExprBoolean(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
int *ptr; /* Where to store 0/1 result. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
int result = TCL_OK;
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a boolean based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = (resultPtr->internalRep.longValue != 0);
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
*ptr = (resultPtr->internalRep.wideValue != 0);
#else
*ptr = (resultPtr->internalRep.longValue != 0);
#endif
} else {
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
if (result != TCL_OK) {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the result boolean to 0 (false).
*/
*ptr = 0;
}
return result;
}
/*
*--------------------------------------------------------------
*
* Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
*
* Procedures to evaluate an expression in an object and return its
* value in a particular form.
*
* Results:
* Each of the procedures below returns a standard Tcl result
* object. If an error occurs then an error message is left in the
* interpreter's result. Otherwise the value of the expression, in the
* appropriate form, is stored at *ptr. If the expression had a result
* that was incompatible with the desired form then an error is
* returned.
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
int
Tcl_ExprLongObj(interp, objPtr, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Expression to evaluate. */
long *ptr; /* Where to store long result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
if (resultPtr->typePtr == &tclIntType) {
*ptr = resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (long) resultPtr->internalRep.doubleValue;
} else {
result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
if (result != TCL_OK) {
return result;
}
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
return result;
}
int
Tcl_ExprDoubleObj(interp, objPtr, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Expression to evaluate. */
double *ptr; /* Where to store double result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
if (resultPtr->typePtr == &tclIntType) {
*ptr = (double) resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = resultPtr->internalRep.doubleValue;
} else {
result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
if (result != TCL_OK) {
return result;
}
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
return result;
}
int
Tcl_ExprBooleanObj(interp, objPtr, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Expression to evaluate. */
int *ptr; /* Where to store 0/1 result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
if (resultPtr->typePtr == &tclIntType) {
*ptr = (resultPtr->internalRep.longValue != 0);
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
} else {
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclInvoke --
*
* Invokes a Tcl command, given an argv/argc, from either the
* exposed or the hidden sets of commands in the given interpreter.
* NOTE: The command is invoked in the current stack frame of
* the interpreter, thus it can modify local variables.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
* TCL_INVOKE_NO_UNKNOWN. */
{
register Tcl_Obj *objPtr;
register int i;
int length, result;
/*
* This procedure generates an objv array for object arguments that hold
* the argv strings. It starts out with stack-allocated space but uses
* dynamically-allocated storage if needed.
*/
#define NUM_ARGS 20
Tcl_Obj *(objStorage[NUM_ARGS]);
register Tcl_Obj **objv = objStorage;
/*
* Create the object argument array "objv". Make sure objv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-objv word.
*/
if ((argc + 1) > NUM_ARGS) {
objv = (Tcl_Obj **)
ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
}
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
objv[i] = Tcl_NewStringObj(argv[i], length);
Tcl_IncrRefCount(objv[i]);
}
objv[argc] = 0;
/*
* Use TclObjInterpProc to actually invoke the command.
*/
result = TclObjInvoke(interp, argc, objv, flags);
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
* Decrement the ref counts on the objv elements since we are done
* with them.
*/
for (i = 0; i < argc; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
/*
* Free the objv array if malloc'ed storage was used.
*/
if (objv != objStorage) {
ckfree((char *) objv);
}
return result;
#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
* TclGlobalInvoke --
*
* Invokes a Tcl command, given an argv/argc, from either the
* exposed or hidden sets of commands in the given interpreter.
* NOTE: The command is invoked in the global stack frame of
* the interpreter, thus it cannot see any current state on
* the stack for that interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclGlobalInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
* TCL_INVOKE_NO_UNKNOWN. */
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
result = TclInvoke(interp, argc, argv, flags);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclObjInvokeGlobal --
*
* Object version: Invokes a Tcl command, given an objv/objc, from
* either the exposed or hidden set of commands in the given
* interpreter.
* NOTE: The command is invoked in the global stack frame of the
* interpreter, thus it cannot see any current state on the
* stack of that interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclObjInvokeGlobal(interp, objc, objv, flags)
Tcl_Interp *interp; /* Interpreter in which command is to be
* invoked. */
int objc; /* Count of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
* name of the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN,
* TCL_INVOKE_NO_UNKNOWN, or
* TCL_INVOKE_NO_TRACEBACK. */
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
result = TclObjInvoke(interp, objc, objv, flags);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclObjInvoke --
*
* Invokes a Tcl command, given an objv/objc, from either the
* exposed or the hidden sets of commands in the given interpreter.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
int
TclObjInvoke(interp, objc, objv, flags)
Tcl_Interp *interp; /* Interpreter in which command is to be
* invoked. */
int objc; /* Count of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
* name of the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN,
* TCL_INVOKE_NO_UNKNOWN, or
* TCL_INVOKE_NO_TRACEBACK. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
char *cmdName; /* Name of the command from objv[0]. */
register Tcl_HashEntry *hPtr;
Tcl_Command cmd;
Command *cmdPtr;
int localObjc; /* Used to invoke "unknown" if the */
Tcl_Obj **localObjv = NULL; /* command is not found. */
register int i;
int result;
if (interp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"illegal argument vector", -1);
return TCL_ERROR;
}
cmdName = Tcl_GetString(objv[0]);
if (flags & TCL_INVOKE_HIDDEN) {
/*
* We never invoke "unknown" for hidden commands.
*/
hPtr = NULL;
hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid hidden command name "", cmdName, """,
(char *) NULL);
return TCL_ERROR;
}
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
} else {
cmdPtr = NULL;
cmd = Tcl_FindCommand(interp, cmdName,
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
if (cmd != (Tcl_Command) NULL) {
cmdPtr = (Command *) cmd;
}
if (cmdPtr == NULL) {
if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
cmd = Tcl_FindCommand(interp, "unknown",
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
if (cmd != (Tcl_Command) NULL) {
cmdPtr = (Command *) cmd;
}
if (cmdPtr != NULL) {
localObjc = (objc + 1);
localObjv = (Tcl_Obj **)
ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
localObjv[0] = Tcl_NewStringObj("unknown", -1);
Tcl_IncrRefCount(localObjv[0]);
for (i = 0; i < objc; i++) {
localObjv[i+1] = objv[i];
}
objc = localObjc;
objv = localObjv;
}
}
/*
* Check again if we found the command. If not, "unknown" is
* not present and we cannot help, or the caller said not to
* call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
*/
if (cmdPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid command name "", cmdName, """,
(char *) NULL);
return TCL_ERROR;
}
}
}
/*
* Invoke the command procedure. First reset the interpreter's string
* and object results to their default empty values since they could
* have gotten changed by earlier invocations.
*/
Tcl_ResetResult(interp);
iPtr->cmdCount++;
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
/*
* If an error occurred, record information about what was being
* executed when the error occurred.
*/
if ((result == TCL_ERROR)
&& ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
&& ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
Tcl_Obj *msg;
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
msg = Tcl_NewStringObj("n while invokingn"", -1);
} else {
msg = Tcl_NewStringObj("n invoked from withinn"", -1);
}
Tcl_IncrRefCount(msg);
for (i = 0; i < objc; i++) {
CONST char *bytes;
int length;
Tcl_AppendObjToObj(msg, objv[i]);
bytes = Tcl_GetStringFromObj(msg, &length);
if (length > 100) {
/*
* Back up truncation point so that we don't truncate
* in the middle of a multi-byte character.
*/
length = 100;
while ( (bytes[length] & 0xC0) == 0x80 ) {
length--;
}
Tcl_SetObjLength(msg, length);
Tcl_AppendToObj(msg, "...", -1);
break;
}
if (i != (objc - 1)) {
Tcl_AppendToObj(msg, " ", -1);
}
}
Tcl_AppendToObj(msg, """, -1);
Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1);
Tcl_DecrRefCount(msg);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
* Free any locally allocated storage used to call "unknown".
*/
if (localObjv != (Tcl_Obj **) NULL) {
Tcl_DecrRefCount(localObjv[0]);
ckfree((char *) localObjv);
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_ExprString --
*
* Evaluate an expression in a string and return its value in string
* form.
*
* Results:
* A standard Tcl result. If the result is TCL_OK, then the interp's
* result is set to the string value of the expression. If the result
* is TCL_ERROR, then the interp's result contains an error message.
*
* Side effects:
* A Tcl object is allocated to hold a copy of the expression string.
* This expression object is passed to Tcl_ExprObj and then
* deallocated.
*
*---------------------------------------------------------------------------
*/
int
Tcl_ExprString(interp, string)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
CONST char *string; /* Expression to evaluate. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
char buf[TCL_DOUBLE_SPACE];
int result = TCL_OK;
if (length > 0) {
TclNewObj(exprPtr);
TclInitStringRep(exprPtr, string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Set the interpreter's string result from the result object.
*/
if (resultPtr->typePtr == &tclIntType) {
sprintf(buf, "%ld", resultPtr->internalRep.longValue);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (resultPtr->typePtr == &tclDoubleType) {
Tcl_PrintDouble((Tcl_Interp *) NULL,
resultPtr->internalRep.doubleValue, buf);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else {
/*
* Set interpreter's string result from the result object.
*/
Tcl_SetResult(interp, TclGetString(resultPtr),
TCL_VOLATILE);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
*/
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
} else {
/*
* An empty string. Just set the interpreter's result to 0.
*/
Tcl_SetResult(interp, "0", TCL_VOLATILE);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateObjTrace --
*
* Arrange for a procedure to be called to trace command execution.
*
* Results:
* The return value is a token for the trace, which may be passed
* to Tcl_DeleteTrace to eliminate the trace.
*
* Side effects:
* From now on, proc will be called just before a command procedure
* is called to execute a Tcl command. Calls to proc will have the
* following form:
*
* void proc( ClientData clientData,
* Tcl_Interp* interp,
* int level,
* CONST char* command,
* Tcl_Command commandInfo,
* int objc,
* Tcl_Obj *CONST objv[] );
*
* The 'clientData' and 'interp' arguments to 'proc' will be the
* same as the arguments to Tcl_CreateObjTrace. The 'level'
* argument gives the nesting depth of command interpretation within
* the interpreter. The 'command' argument is the ASCII text of
* the command being evaluated -- before any substitutions are
* performed. The 'commandInfo' argument gives a handle to the
* command procedure that will be evaluated. The 'objc' and 'objv'
* parameters give the parameter vector that will be passed to the
* command procedure. proc does not return a value.
*
* It is permissible for 'proc' to call Tcl_SetCommandTokenInfo
* to change the command procedure or client data for the command
* being evaluated, and these changes will take effect with the
* current evaluation.
*
* The 'level' argument specifies the maximum nesting level of calls
* to be traced. If the execution depth of the interpreter exceeds
* 'level', the trace callback is not executed.
*
* The 'flags' argument is either zero or the value,
* TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION
* flag is not present, the bytecode compiler will not generate inline
* code for Tcl's built-in commands. This behavior will have a significant
* impact on performance, but will ensure that all command evaluations are
* traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
* bytecode compiler will have its normal behavior of compiling in-line
* code for some of Tcl's built-in commands. In this case, the tracing
* will be imprecise -- in-line code will not be traced -- but run-time
* performance will be improved. The latter behavior is desired for
* many applications such as profiling of run time.
*
* When the trace is deleted, the 'delProc' procedure will be invoked,
* passing it the original client data.
*
*----------------------------------------------------------------------
*/
Tcl_Trace
Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc )
Tcl_Interp* interp; /* Tcl interpreter */
int level; /* Maximum nesting level */
int flags; /* Flags, see above */
Tcl_CmdObjTraceProc* proc; /* Trace callback */
ClientData clientData; /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc* delProc;
/* Procedure to call when trace is deleted */
{
register Trace *tracePtr;
register Interp *iPtr = (Interp *) interp;
/* Test if this trace allows inline compilation of commands */
if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) {
if (iPtr->tracesForbiddingInline == 0) {
/*
* When the first trace forbidding inline compilation is
* created, invalidate existing compiled code for this
* interpreter and arrange (by setting the
* DONT_COMPILE_CMDS_INLINE flag) that when compiling new
* code, no commands will be compiled inline (i.e., into
* an inline sequence of instructions). We do this because
* commands that were compiled inline will never result in
* a command trace being called.
*/
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
tracePtr = (Trace *) ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
tracePtr->delProc = delProc;
tracePtr->nextPtr = iPtr->tracePtr;
tracePtr->flags = flags;
iPtr->tracePtr = tracePtr;
return (Tcl_Trace) tracePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateTrace --
*
* Arrange for a procedure to be called to trace command execution.
*
* Results:
* The return value is a token for the trace, which may be passed
* to Tcl_DeleteTrace to eliminate the trace.
*
* Side effects:
* From now on, proc will be called just before a command procedure
* is called to execute a Tcl command. Calls to proc will have the
* following form:
*
* void
* proc(clientData, interp, level, command, cmdProc, cmdClientData,
* argc, argv)
* ClientData clientData;
* Tcl_Interp *interp;
* int level;
* char *command;
* int (*cmdProc)();
* ClientData cmdClientData;
* int argc;
* char **argv;
* {
* }
*
* The clientData and interp arguments to proc will be the same
* as the corresponding arguments to this procedure. Level gives
* the nesting level of command interpretation for this interpreter
* (0 corresponds to top level). Command gives the ASCII text of
* the raw command, cmdProc and cmdClientData give the procedure that
* will be called to process the command and the ClientData value it
* will receive, and argc and argv give the arguments to the
* command, after any argument parsing and substitution. Proc
* does not return a value.
*
*----------------------------------------------------------------------
*/
Tcl_Trace
Tcl_CreateTrace(interp, level, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which to create trace. */
int level; /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
* command. */
ClientData clientData; /* Arbitrary value word to pass to proc. */
{
StringTraceData* data;
data = (StringTraceData*) ckalloc( sizeof( *data ));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
(ClientData) data, StringTraceDeleteProc );
}
/*
*----------------------------------------------------------------------
*
* StringTraceProc --
*
* Invoke a string-based trace procedure from an object-based
* callback.
*
* Results:
* None.
*
* Side effects:
* Whatever the string-based trace procedure does.
*
*----------------------------------------------------------------------
*/
static int
StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv )
ClientData clientData;
Tcl_Interp* interp;
int level;
CONST char* command;
Tcl_Command commandInfo;
int objc;
Tcl_Obj *CONST *objv;
{
StringTraceData* data = (StringTraceData*) clientData;
Command* cmdPtr = (Command*) commandInfo;
CONST char** argv; /* Args to pass to string trace proc */
int i;
/*
* This is a bit messy because we have to emulate the old trace
* interface, which uses strings for everything.
*/
argv = (CONST char **) ckalloc((unsigned) ( (objc + 1)
* sizeof(CONST char *) ));
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
argv[objc] = 0;
/*
* Invoke the command procedure. Note that we cast away const-ness
* on two parameters for compatibility with legacy code; the code
* MUST NOT modify either command or argv.
*/
( data->proc )( data->clientData, interp, level,
(char*) command, cmdPtr->proc, cmdPtr->clientData,
objc, argv );
ckfree( (char*) argv );
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringTraceDeleteProc --
*
* Clean up memory when a string-based trace is deleted.
*
* Results:
* None.
*
* Side effects:
* Allocated memory is returned to the system.
*
*----------------------------------------------------------------------
*/
static void
StringTraceDeleteProc( clientData )
ClientData clientData;
{
ckfree( (char*) clientData );
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteTrace --
*
* Remove a trace.
*
* Results:
* None.
*
* Side effects:
* From now on there will be no more calls to the procedure given
* in trace.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteTrace(interp, trace)
Tcl_Interp *interp; /* Interpreter that contains trace. */
Tcl_Trace trace; /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
Interp *iPtr = (Interp *) interp;
Trace *prevPtr, *tracePtr = (Trace *) trace;
register Trace **tracePtr2 = &(iPtr->tracePtr);
ActiveInterpTrace *activePtr;
/*
* Locate the trace entry in the interpreter's trace list,
* and remove it from the list.
*/
prevPtr = NULL;
while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) {
prevPtr = *tracePtr2;
tracePtr2 = &((*tracePtr2)->nextPtr);
}
if (*tracePtr2 == NULL) {
return;
}
(*tracePtr2) = (*tracePtr2)->nextPtr;
/*
* The code below makes it possible to delete traces while traces
* are active: it makes sure that the deleted trace won't be
* processed by TclCheckInterpTraces.
*/
for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
if (activePtr->reverseScan) {
activePtr->nextTracePtr = prevPtr;
} else {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
}
/*
* If the trace forbids bytecode compilation, change the interpreter's
* state. If bytecode compilation is now permitted, flag the fact and
* advance the compilation epoch so that procs will be recompiled to
* take advantage of it.
*/
if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) {
iPtr->tracesForbiddingInline--;
if (iPtr->tracesForbiddingInline == 0) {
iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
iPtr->compileEpoch++;
}
}
/*
* Execute any delete callback.
*/
if (tracePtr->delProc != NULL) {
(tracePtr->delProc)(tracePtr->clientData);
}
/* Delete the trace object */
Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AddErrorInfo --
*
* Add information to the "errorInfo" variable that describes the
* current error.
*
* Results:
* None.
*
* Side effects:
* The contents of message are added to the "errorInfo" variable.
* If Tcl_Eval has been called since the current value of errorInfo
* was set, errorInfo is cleared before adding the new message.
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
void
Tcl_AddErrorInfo(interp, message)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
CONST char *message; /* Message to record. */
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AddObjErrorInfo --
*
* Add information to the "errorInfo" variable that describes the
* current error. This routine differs from Tcl_AddErrorInfo by
* taking a byte pointer and length.
*
* Results:
* None.
*
* Side effects:
* "length" bytes from "message" are added to the "errorInfo" variable.
* If "length" is negative, use bytes up to the first NULL byte.
* If Tcl_EvalObj has been called since the current value of errorInfo
* was set, errorInfo is cleared before adding the new message.
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
void
Tcl_AddObjErrorInfo(interp, message, length)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
CONST char *message; /* Points to the first byte of an array of
* bytes of the message. */
int length; /* The number of bytes in the message.
* If < 0, then append all bytes up to a
* NULL byte. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr;
/*
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*/
if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
iPtr->flags |= ERR_IN_PROGRESS;
if (iPtr->result[0] == 0) {
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
iPtr->objResultPtr, TCL_GLOBAL_ONLY);
} else { /* use the string result */
objPtr = Tcl_NewStringObj(interp->result, -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
}
/*
* If the errorCode variable wasn't set by the code that generated
* the error, set it to "NONE".
*/
if (!(iPtr->flags & ERROR_CODE_SET)) {
objPtr = Tcl_NewStringObj("NONE", -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
}
}
/*
* Now append "message" to the end of errorInfo.
*/
if (length != 0) {
objPtr = Tcl_NewStringObj(message, length);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
Tcl_DecrRefCount(objPtr); /* free msg object appended above */
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
* Given a variable number of string arguments, concatenate them
* all together and execute the result as a Tcl command.
*
* Results:
* A standard Tcl return result. An error message or other result may
* be left in the interp's result.
*
* Side effects:
* Depends on what was done by the command.
*
*---------------------------------------------------------------------------
*/
int
Tcl_VarEvalVA (interp, argList)
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
va_list argList; /* Variable argument list. */
{
Tcl_DString buf;
char *string;
int result;
/*
* Copy the strings one after the other into a single larger
* string. Use stack-allocated space for small commands, but if
* the command gets too large than call ckalloc to create the
* space.
*/
Tcl_DStringInit(&buf);
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
Tcl_DStringAppend(&buf, string, -1);
}
result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_VarEval --
*
* Given a variable number of string arguments, concatenate them
* all together and execute the result as a Tcl command.
*
* Results:
* A standard Tcl return result. An error message or other
* result may be left in interp->result.
*
* Side effects:
* Depends on what was done by the command.
*
*----------------------------------------------------------------------
*/
/* VARARGS2 */ /* ARGSUSED */
int
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
Tcl_Interp *interp;
va_list argList;
int result;
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
result = Tcl_VarEvalVA(interp, argList);
va_end(argList);
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_GlobalEval --
*
* Evaluate a command at global level in an interpreter.
*
* Results:
* A standard Tcl result is returned, and the interp's result is
* modified accordingly.
*
* Side effects:
* The command string is executed in interp, and the execution
* is carried out in the variable context of global level (no
* procedures active), just as if an "uplevel #0" command were
* being executed.
*
---------------------------------------------------------------------------
*/
int
Tcl_GlobalEval(interp, command)
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
CONST char *command; /* Command to evaluate. */
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
result = Tcl_Eval(interp, command);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetRecursionLimit --
*
* Set the maximum number of recursive calls that may be active
* for an interpreter at once.
*
* Results:
* The return value is the old limit on nesting for interp.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetRecursionLimit(interp, depth)
Tcl_Interp *interp; /* Interpreter whose nesting limit
* is to be set. */
int depth; /* New value for maximimum depth. */
{
Interp *iPtr = (Interp *) interp;
int old;
old = iPtr->maxNestingDepth;
if (depth > 0) {
iPtr->maxNestingDepth = depth;
}
return old;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AllowExceptions --
*
* Sets a flag in an interpreter so that exceptions can occur
* in the next call to Tcl_Eval without them being turned into
* errors.
*
* Results:
* None.
*
* Side effects:
* The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
* evalFlags structure. See the reference documentation for
* more details.
*
*----------------------------------------------------------------------
*/
void
Tcl_AllowExceptions(interp)
Tcl_Interp *interp; /* Interpreter in which to set flag. */
{
Interp *iPtr = (Interp *) interp;
iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVersion
*
* Get the Tcl major, minor, and patchlevel version numbers and
* the release type. A patch is a release type TCL_FINAL_RELEASE
* with a patchLevel > 0.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetVersion(majorV, minorV, patchLevelV, type)
int *majorV;
int *minorV;
int *patchLevelV;
int *type;
{
if (majorV != NULL) {
*majorV = TCL_MAJOR_VERSION;
}
if (minorV != NULL) {
*minorV = TCL_MINOR_VERSION;
}
if (patchLevelV != NULL) {
*patchLevelV = TCL_RELEASE_SERIAL;
}
if (type != NULL) {
*type = TCL_RELEASE_LEVEL;
}
}
#ifdef USE_DTRACE
/*
*----------------------------------------------------------------------
*
* DTraceObjCmd --
*
* This function is invoked to process the "::tcl::dtrace" Tcl command.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* The 'tcl-probe' DTrace probe is triggered (if it is enabled).
*
*----------------------------------------------------------------------
*/
static int
DTraceObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
if (TCL_DTRACE_TCL_PROBE_ENABLED()) {
char *a[10];
int i = 0;
while (i++ < 10) {
a[i-1] = i < objc ? TclGetString(objv[i]) : NULL;
}
TCL_DTRACE_TCL_PROBE(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
return TCL_OK;
}
#endif /* USE_DTRACE */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/