通讯编程

开发平台：

Visual C++

tclCmdMZ.c：源码内容

case SUBST_NOCOMMANDS: {
flags &= ~TCL_SUBST_COMMANDS;
break;
}
case SUBST_NOVARS: {
flags &= ~TCL_SUBST_VARIABLES;
break;
}
default: {
panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
}
}
}
if (i != (objc-1)) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-nobackslashes? ?-nocommands? ?-novariables? string");
return TCL_ERROR;
}
/*
* Perform the substitution.
*/
resultPtr = Tcl_SubstObj(interp, objv[i], flags);
if (resultPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SubstObj --
*
* This function performs the substitutions specified on the
* given string as described in the user documentation for the
* "subst" Tcl command. This code is heavily based on an
* implementation by Andrew Payne. Note that if a command
* substitution returns TCL_CONTINUE or TCL_RETURN from its
* evaluation and is not completely well-formed, the results are
* not defined (or at least hard to characterise.) This fault
* will be fixed at some point, but the cost of the only sane
* fix (well-formedness check first) is such that you need to
* "precompile and cache" to stop everyone from being hit with
* the consequences every time through. Note that the current
* behaviour is not a security hole; it just restarts parsing
* the string following the substitution in a mildly surprising
* place, and it is a very bad idea to count on this remaining
* the same in future...
*
* Results:
* A Tcl_Obj* containing the substituted string, or NULL to
* indicate that an error occurred.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_SubstObj(interp, objPtr, flags)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
int flags;
{
Tcl_Obj *resultObj;
char *p, *old;
int length;
old = p = Tcl_GetStringFromObj(objPtr, &length);
resultObj = Tcl_NewStringObj("", 0);
while (length) {
switch (*p) {
case '\':
if (flags & TCL_SUBST_BACKSLASHES) {
char buf[TCL_UTF_MAX];
int count;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
Tcl_AppendToObj(resultObj, buf,
Tcl_UtfBackslash(p, &count, buf));
p += count; length -= count;
old = p;
} else {
p++; length--;
}
break;
case '$':
if (flags & TCL_SUBST_VARIABLES) {
Tcl_Parse parse;
int code;
/*
* Code is simpler overall if we (effectively) inline
* Tcl_ParseVar, particularly as that allows us to use
* a non-string interface when we come to appending
* the variable contents to the result object. There
* are a few other optimisations that doing this
* enables (like being able to continue the run of
* unsubstituted characters straight through if a '$'
* does not precede a variable name.)
*/
if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) {
goto errorResult;
}
if (parse.numTokens == 1) {
/*
* There isn't a variable name after all: the $ is
* just a $.
*/
p++; length--;
break;
}
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
p += parse.tokenPtr->size;
length -= parse.tokenPtr->size;
code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
parse.numTokens);
if (code == TCL_ERROR) {
goto errorResult;
}
if (code == TCL_BREAK) {
Tcl_ResetResult(interp);
return resultObj;
}
if (code != TCL_CONTINUE) {
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
}
Tcl_ResetResult(interp);
old = p;
} else {
p++; length--;
}
break;
case '[':
if (flags & TCL_SUBST_COMMANDS) {
Interp *iPtr = (Interp *) interp;
int code;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
iPtr->evalFlags = TCL_BRACKET_TERM;
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
code = Tcl_EvalEx(interp, p+1, -1, 0);
}
iPtr->numLevels--;
switch (code) {
case TCL_ERROR:
goto errorResult;
case TCL_BREAK:
Tcl_ResetResult(interp);
return resultObj;
default:
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
case TCL_CONTINUE:
Tcl_ResetResult(interp);
old = p = (p+1 + iPtr->termOffset + 1);
length -= (iPtr->termOffset + 2);
}
} else {
p++; length--;
}
break;
default:
p++; length--;
break;
}
}
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
return resultObj;
errorResult:
Tcl_DecrRefCount(resultObj);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SwitchObjCmd --
*
* This object-based procedure is invoked to process the "switch" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, j, index, mode, matched, result, splitObjs;
char *string, *pattern;
Tcl_Obj *stringObj;
Tcl_Obj *CONST *savedObjv = objv;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
int pc = 0;
int bidx = 0; /* Index of body argument */
Tcl_Obj* blist = NULL; /* List obj which is the body */
CmdFrame ctx; /* Copy of the topmost cmdframe,
* to allow us to mess with the
* line information */
#endif
static CONST char *options[] = {
"-exact", "-glob", "-regexp", "--",
NULL
};
enum options {
OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
};
mode = OPT_EXACT;
for (i = 1; i < objc; i++) {
string = Tcl_GetString(objv[i]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_LAST) {
i++;
break;
}
mode = index;
}
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
stringObj = objv[i];
objc -= i + 1;
objv += i + 1;
#ifdef TCL_TIP280
bidx = i+1; /* First after the match string */
#endif
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*
* TIP #280: Determine the lines the words in the list start at, based on
* the same data for the list word itself. The cmdFramePtr line information
* is manipulated directly.
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
#ifdef TCL_TIP280
blist = objv[0];
#endif
if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
"?switches? string {pattern body ... ?default body?}");
return TCL_ERROR;
}
objv = listv;
splitObjs = 1;
}
/*
* Complain if there is an odd number of words in the list of
* patterns and bodies.
*/
if (objc % 2) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
/*
* Check if this can be due to a badly placed comment
* in the switch block.
*
* The following is an heuristic to detect the infamous
* "comment in switch" error: just check if a pattern
* begins with '#'.
*/
if (splitObjs) {
for (i=0 ; i<objc ; i+=2) {
if (Tcl_GetString(objv[i])[0] == '#') {
Tcl_AppendResult(interp, ", this may be due to a ",
"comment incorrectly placed outside of a ",
"switch body - see the "switch" ",
"documentation", NULL);
break;
}
}
}
return TCL_ERROR;
}
/*
* Complain if the last body is a continuation. Note that this
* check assumes that the list is non-empty!
*/
if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "no body specified for pattern "",
Tcl_GetString(objv[objc-2]), """, NULL);
return TCL_ERROR;
}
for (i = 0; i < objc; i += 2) {
/*
* See if the pattern matches the string.
*/
pattern = Tcl_GetString(objv[i]);
matched = 0;
if ((i == objc - 2)
&& (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
matched = 1;
} else {
switch (mode) {
case OPT_EXACT:
matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
break;
case OPT_GLOB:
matched = Tcl_StringMatch(Tcl_GetString(stringObj),
pattern);
break;
case OPT_REGEXP:
matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
if (matched < 0) {
return TCL_ERROR;
}
break;
}
}
if (matched == 0) {
continue;
}
/*
* We've got a match. Find a body to execute, skipping bodies
* that are "-".
*
* TIP#280: Now is also the time to determine a line number for the
* single-word case.
*/
#ifdef TCL_TIP280
ctx = *iPtr->cmdFramePtr;
if (splitObjs) {
/* We have to perform the GetSrc and other type dependent handling
* of the frame here because we are munging with the line numbers,
* something the other commands like if, etc. are not doing. Them
* are fine with simply passing the CmdFrame through and having
* the special handling done in 'info frame', or the bc compiler
*/
if (ctx.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;
/* The line information in the cmdFrame is now a copy we do
* not own */
}
if (ctx.type == TCL_LOCATION_SOURCE) {
int bline = ctx.line [bidx];
if (bline >= 0) {
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
ListLines (Tcl_GetString (blist), bline, objc, ctx.line);
} else {
int k;
/* Dynamic code word ... All elements are relative to themselves */
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
for (k=0; k < objc; k++) {ctx.line[k] = -1;}
}
} else {
int k;
/* Anything else ... No information, or dynamic ... */
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
for (k=0; k < objc; k++) {ctx.line[k] = -1;}
}
}
#endif
for (j = i + 1; ; j += 2) {
if (j >= objc) {
/*
* This shouldn't happen since we've checked that the
* last body is not a continuation...
*/
panic("fall-out when searching for body to match pattern");
}
if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
}
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[j], 0);
#else
/* TIP #280. Make invoking context available to switch branch */
result = TclEvalObjEx(interp, objv[j], 0, &ctx, j);
if (splitObjs) {
ckfree ((char*) ctx.line);
if (pc && (ctx.type == TCL_LOCATION_SOURCE)) {
/* Death of SrcInfo reference */
Tcl_DecrRefCount (ctx.data.eval.path);
}
}
#endif
if (result == TCL_ERROR) {
char msg[100 + TCL_INTEGER_SPACE];
sprintf(msg, "n ("%.50s" arm line %d)", pattern,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
return result;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TimeObjCmd --
*
* This object-based procedure is invoked to process the "time" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
register int i, result;
int count;
double totalMicroSec;
Tcl_Time start, stop;
if (objc == 2) {
count = 1;
} else if (objc == 3) {
result = Tcl_GetIntFromObj(interp, objv[2], &count);
if (result != TCL_OK) {
return result;
}
} else {
Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
return TCL_ERROR;
}
objPtr = objv[1];
i = count;
Tcl_GetTime(&start);
while (i-- > 0) {
result = Tcl_EvalObjEx(interp, objPtr, 0);
if (result != TCL_OK) {
return result;
}
}
Tcl_GetTime(&stop);
totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
+ ( stop.usec - start.usec ) );
if (count <= 1) {
/* Use int obj since we know time is not fractional [Bug 1202178] */
objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec);
} else {
objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
}
objs[1] = Tcl_NewStringObj("microseconds", -1);
objs[2] = Tcl_NewStringObj("per", -1);
objs[3] = Tcl_NewStringObj("iteration", -1);
Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceObjCmd --
*
* This procedure is invoked to process the "trace" Tcl command.
* See the user documentation for details on what it does.
*
* Standard syntax as of Tcl 8.4 is
*
* trace {add|info|remove} {command|variable} name ops cmd
*
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_TraceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int optionIndex;
char *name, *flagOps, *p;
/* Main sub commands to 'trace' */
static CONST char *traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
(char *) NULL
};
/* 'OLD' options are pre-Tcl-8.4 style */
enum traceOptions {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
#ifndef TCL_REMOVE_OBSOLETE_TRACES
TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE:
case TRACE_INFO: {
/*
* All sub commands of trace add/remove must take at least
* one more argument. Beyond that we let the subcommand itself
* control the argument structure.
*/
int typeIndex;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
"option", 0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
opsList = Tcl_NewObj();
Tcl_IncrRefCount(opsList);
flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
if (numFlags == 0) {
Tcl_DecrRefCount(opsList);
goto badVarOps;
}
for (p = flagOps; *p != 0; p++) {
if (*p == 'r') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("read", -1));
} else if (*p == 'w') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("write", -1));
} else if (*p == 'u') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("unset", -1));
} else if (*p == 'a') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("array", -1));
} else {
Tcl_DecrRefCount(opsList);
goto badVarOps;
}
}
copyObjv[0] = NULL;
memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *));
copyObjv[4] = opsList;
if (optionIndex == TRACE_OLD_VARIABLE) {
code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv);
} else {
code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv);
}
Tcl_DecrRefCount(opsList);
return code;
}
case TRACE_OLD_VINFO: {
ClientData clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[2]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
p = ops;
if (tvarPtr->flags & TCL_TRACE_READS) {
*p = 'r';
p++;
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
*p = 'w';
p++;
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
*p = 'u';
p++;
}
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
*p = 'a';
p++;
}
*p = '';
/*
* Build a pair (2-item list) with the ops string as
* the first obj element and the tvarPtr->command string
* as the second obj element. Append the pair (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewStringObj(ops, -1);
Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
#endif /* TCL_REMOVE_OBSOLETE_TRACES */
}
return TCL_OK;
badVarOps:
Tcl_AppendResult(interp, "bad operations "", flagOps,
"": should be one or more of rwua", (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclTraceExecutionObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|remove|info} execution ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove command traces on a command.
*
*----------------------------------------------------------------------
*/
int
TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "enter", "leave",
"enterstep", "leavestep", (char *) NULL };
enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list "": must be "
"one or more of enter, leave, enterstep, or leavestep",
TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_EXEC_ENTER:
flags |= TCL_TRACE_ENTER_EXEC;
break;
case TRACE_EXEC_LEAVE:
flags |= TCL_TRACE_LEAVE_EXEC;
break;
case TRACE_EXEC_ENTER_STEP:
flags |= TCL_TRACE_ENTER_DURING_EXEC;
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC |
TCL_TRACE_LEAVE_EXEC);
}
strcpy(tcmdPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceCommandInfo *tcmdPtr;
ClientData clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
tcmdPtr = (TraceCommandInfo *) clientData;
/*
* In checking the 'flags' field we must remove any
* extraneous flags which may have been temporarily
* added by various pieces of the trace mechanism.
*/
if ((tcmdPtr->length == length)
&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC |
TCL_TRACE_RENAME |
TCL_TRACE_DELETE)) == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC |
TCL_TRACE_LEAVE_EXEC);
}
Tcl_UntraceCommand(interp, name,
flags, TraceCommandProc, clientData);
if (tcmdPtr->stepTrace != NULL) {
/*
* We need to remove the interpreter-wide trace
* which we created to allow 'step' traces.
*/
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/* Postpone deletion */
tcmdPtr->flags = 0;
}
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
int numOps = 0;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
/*
* Build a list with the ops list as the first obj
* element and the tcmdPtr->command string as the
* second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_IncrRefCount(elemObjPtr);
if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enter",5));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leave",5));
}
if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enterstep",9));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leavestep",9));
}
Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
elemObjPtr = NULL;
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr,
Tcl_NewStringObj(tcmdPtr->command, -1));
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclTraceCommandObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|info|remove} command ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove command traces on a command.
*
*----------------------------------------------------------------------
*/
int
TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list "": must be "
"one or more of delete or rename", TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_CMD_RENAME:
flags |= TCL_TRACE_RENAME;
break;
case TRACE_CMD_DELETE:
flags |= TCL_TRACE_DELETE;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
strcpy(tcmdPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceCommandInfo *tcmdPtr;
ClientData clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
tcmdPtr = (TraceCommandInfo *) clientData;
if ((tcmdPtr->length == length)
&& (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name,
flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char *) tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
clientData = NULL;
name = Tcl_GetString(objv[3]);
/* First ensure the name given is valid */
if (Tcl_FindCommand(interp, name, NULL,
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
int numOps = 0;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
/*
* Build a list with the ops list as
* the first obj element and the tcmdPtr->command string
* as the second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_IncrRefCount(elemObjPtr);
if (tcmdPtr->flags & TCL_TRACE_RENAME) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("rename",6));
}
if (tcmdPtr->flags & TCL_TRACE_DELETE) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("delete",6));
}
Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclTraceVariableObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|info|remove} variable ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove variable traces on a variable.
*
*----------------------------------------------------------------------
*/
int
TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "array", "read", "unset", "write",
(char *) NULL };
enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
TRACE_VAR_WRITE };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list "": must be "
"one or more of array, read, unset, or write",
TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen ; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_VAR_ARRAY:
flags |= TCL_TRACE_ARRAY;
break;
case TRACE_VAR_READ:
flags |= TCL_TRACE_READS;
break;
case TRACE_VAR_UNSET:
flags |= TCL_TRACE_UNSETS;
break;
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
/*
* This code essentially mallocs together the VarTrace and the
* TraceVarInfo, then inlines the Tcl_TraceVar(). This is
* necessary in order to have the TraceVarInfo to be freed
* automatically when the VarTrace is freed [Bug 1348775]
*/
CompoundVarTrace *compTracePtr;
TraceVarInfo *tvarPtr;
Var *varPtr, *arrayPtr;
VarTrace *tracePtr;
int flagMask;
compTracePtr = (CompoundVarTrace *) ckalloc((unsigned)
(sizeof(CompoundVarTrace) - sizeof(tvarPtr->command)
+ length + 1));
tracePtr = &(compTracePtr->trace);
tvarPtr = &(compTracePtr->tvar);
tvarPtr->flags = flags;
if (objv[0] == NULL) {
tvarPtr->flags |= TCL_TRACE_OLD_STYLE;
}
tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
strcpy(tvarPtr->command, command);
name = Tcl_GetString(objv[3]);
flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
varPtr = TclLookupVar(interp, name, NULL,
(flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
ckfree((char *) tracePtr);
return TCL_ERROR;
}
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES
| TCL_TRACE_UNSETS | TCL_TRACE_ARRAY
| TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
tracePtr->traceProc = TraceVarProc;
tracePtr->clientData = (ClientData) tvarPtr;
tracePtr->flags = flags & flagMask;
tracePtr->nextPtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr;
} else {
/*
* Search through all of our traces on this variable to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceVarInfo *tvarPtr;
ClientData clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length)
&& ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
/*
* Build a list with the ops list as
* the first obj element and the tcmdPtr->command string
* as the second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (tvarPtr->flags & TCL_TRACE_ARRAY) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("array", 5));
}
if (tvarPtr->flags & TCL_TRACE_READS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("read", 4));
}
if (tvarPtr->flags & TCL_TRACE_WRITES) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("write", 5));
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("unset", 5));
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CommandTraceInfo --
*
* Return the clientData value associated with a trace on a
* command. This procedure can also be used to step through
* all of the traces on a particular command that have the
* same trace procedure.
*
* Results:
* The return value is the clientData value associated with
* a trace on the given command. Information will only be
* returned for a trace with proc as trace procedure. If
* the clientData argument is NULL then the first such trace is
* returned; otherwise, the next relevant one after the one
* given by clientData will be returned. If the command
* doesn't exist then an error message is left in the interpreter
* and NULL is returned. Also, if there are no (more) traces for
* the given command, NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY (can be 0). */
Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
ClientData prevClientData; /* If non-NULL, gives last value returned
* by this procedure, so this call will
* return the next trace after that one.
* If NULL, this call will return the
* first trace. */
{
Command *cmdPtr;
register CommandTrace *tracePtr;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return NULL;
}
/*
* Find the relevant trace, if any, and return its clientData.
*/
tracePtr = cmdPtr->tracePtr;
if (prevClientData != NULL) {
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
&& (tracePtr->traceProc == proc)) {
tracePtr = tracePtr->nextPtr;
break;
}
}
}
for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if (tracePtr->traceProc == proc) {
return tracePtr->clientData;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceCommand --
*
* Arrange for rename/deletes to a command to cause a
* procedure to be invoked, which can monitor the operations.
*
* Also optionally arrange for execution of that command
* to cause a procedure to be invoked.
*
* Results:
* A standard Tcl return value.
*
* Side effects:
* A trace is set up on the command given by cmdName, such that
* future changes to the command will be intermediated by
* proc. See the manual entry for complete details on the calling
* sequence for proc.
*
*----------------------------------------------------------------------
*/
int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which command is
* to be traced. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
* and any of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
register CommandTrace *tracePtr;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return TCL_ERROR;
}
/*
* Set up trace information.
*/
tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE
| TCL_TRACE_ANY_EXEC);
tracePtr->nextPtr = cmdPtr->tracePtr;
tracePtr->refCount = 1;
cmdPtr->tracePtr = tracePtr;
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceCommand --
*
* Remove a previously-created trace for a command.
*
* Results:
* None.
*
* Side effects:
* If there exists a trace for the command given by cmdName
* with the given flags, proc, and clientData, then that trace
* is removed.
*
*----------------------------------------------------------------------
*/
void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
* and any of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
register CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
ActiveCommandTrace *activePtr;
int hasExecTraces = 0;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return;
}
flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
return;
}
if ((tracePtr->traceProc == proc)
&& ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE |
TCL_TRACE_ANY_EXEC)) == flags)
&& (tracePtr->clientData == clientData)) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
hasExecTraces = 1;
}
break;
}
}
/*
* 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 CallCommandTraces.
*/
for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
if (activePtr->reverseScan) {
activePtr->nextTracePtr = prevPtr;
} else {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
}
if (prevPtr == NULL) {
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
if ((--tracePtr->refCount) <= 0) {
ckfree((char*)tracePtr);
}
if (hasExecTraces) {
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
return;
}
}
/*
* None of the remaining traces on this command are execution
* traces. We therefore remove this flag:
*/
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
}
}
/*
*----------------------------------------------------------------------
*
* TraceCommandProc --
*
* This procedure is called to handle command changes that have
* been traced using the "trace" command, when using the
* 'rename' or 'delete' options.
*
* Results:
* None.
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
TraceCommandProc(clientData, interp, oldName, newName, flags)
ClientData clientData; /* Information about the command trace. */
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *oldName; /* Name of command being changed. */
CONST char *newName; /* New name of command. Empty string
* or NULL means command is being deleted
* (renamed to ""). */
int flags; /* OR-ed bits giving operation and other
* information. */
{
Interp *iPtr = (Interp *) interp;
int stateCode;
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
tcmdPtr->refCount++;
if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
/*
* Generate a command to execute by appending list elements
* for the old and new command name and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
Tcl_DStringAppend(&cmd, " rename", 7);
} else if (flags & TCL_TRACE_DELETE) {
Tcl_DStringAppend(&cmd, " delete", 7);
}
/*
* Execute the command. Save the interp's result used for the
* command, including the value of iPtr->returnCode which may be
* modified when Tcl_Eval is invoked. We discard any object
* result the command returns.
*
* Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to
* other areas that this will be destroyed by us, otherwise a
* double-free might occur depending on what the eval does.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
if (flags & TCL_TRACE_DESTROYED) {
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
}
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) {
/* We ignore errors in these traced commands */
}
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
Tcl_DStringFree(&cmd);
}
/*
* We delete when the trace was destroyed or if this is a delete trace,
* because command deletes are unconditional, so the trace must go away.
*/
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
int untraceFlags = tcmdPtr->flags;
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/* Postpone deletion, until exec trace returns */
tcmdPtr->flags = 0;
}
/*
* We need to construct the same flags for Tcl_UntraceCommand
* as were passed to Tcl_TraceCommand. Reproduce the processing
* of [trace add execution/command]. Be careful to keep this
* code in sync with that.
*/
if (untraceFlags & TCL_TRACE_ANY_EXEC) {
untraceFlags |= TCL_TRACE_DELETE;
if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC
| TCL_TRACE_LEAVE_DURING_EXEC)) {
untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
} else if (untraceFlags & TCL_TRACE_RENAME) {
untraceFlags |= TCL_TRACE_DELETE;
}
/*
* Remove the trace since TCL_TRACE_DESTROYED tells us to, or the
* command we're tracing has just gone away. Then decrement the
* clientData refCount that was set up by trace creation.
*
* Note that we save the (return) state of the interpreter to prevent
* bizarre error messages.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
tcmdPtr->refCount--;
}
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
return;
}
/*
*----------------------------------------------------------------------
*
* TclCheckExecutionTraces --
*
* Checks on all current command execution traces, and invokes
* procedures which have been registered. This procedure can be
* used by other code which performs execution to unify the
* tracing system, so that execution traces will function for that
* other code.
*
* For instance extensions like [incr Tcl] which use their
* own execution technique can make use of Tcl's tracing.
*
* This procedure is called by 'TclEvalObjvInternal'
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* Those side effects made by any trace procedures called.
*
*----------------------------------------------------------------------
*/
int
TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code,
traceFlags, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
CONST char *command; /* Pointer to beginning of the current
* command string. */
int numChars; /* The number of characters in 'command'
* which are part of the command string. */
Command *cmdPtr; /* Points to command's Command struct. */
int code; /* The current result code. */
int traceFlags; /* Current tracing situation. */
int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
CommandTrace *tracePtr, *lastTracePtr;
ActiveCommandTrace active;
int curLevel;
int traceCode = TCL_OK;
TraceCommandInfo* tcmdPtr;
if (command == NULL || cmdPtr->tracePtr == NULL) {
return traceCode;
}
curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
active.nextPtr = iPtr->activeCmdTracePtr;
iPtr->activeCmdTracePtr = &active;
active.cmdPtr = cmdPtr;
lastTracePtr = NULL;
for (tracePtr = cmdPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
/* execute the trace command in order of creation for "leave" */
active.reverseScan = 1;
active.nextTracePtr = NULL;
tracePtr = cmdPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
tcmdPtr->curCode = code;
tcmdPtr->refCount++;
traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
}
iPtr->activeCmdTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* TclCheckInterpTraces --
*
* Checks on all current traces, and invokes procedures which
* have been registered. This procedure can be used by other
* code which performs execution to unify the tracing system.
* For instance extensions like [incr Tcl] which use their
* own execution technique can make use of Tcl's tracing.
*
* This procedure is called by 'TclEvalObjvInternal'
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* Those side effects made by any trace procedures called.
*
*----------------------------------------------------------------------
*/
int
TclCheckInterpTraces(interp, command, numChars, cmdPtr, code,
traceFlags, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
CONST char *command; /* Pointer to beginning of the current
* command string. */
int numChars; /* The number of characters in 'command'
* which are part of the command string. */
Command *cmdPtr; /* Points to command's Command struct. */
int code; /* The current result code. */
int traceFlags; /* Current tracing situation. */
int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
int curLevel;
int traceCode = TCL_OK;
if (command == NULL || iPtr->tracePtr == NULL ||
(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
return(traceCode);
}
curLevel = iPtr->numLevels;
active.nextPtr = iPtr->activeInterpTracePtr;
iPtr->activeInterpTracePtr = &active;
lastTracePtr = NULL;
for ( tracePtr = iPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
/*
* Execute the trace command in reverse order of creation
* for "enterstep" operation. The order is changed for
* "enterstep" instead of for "leavestep" as was done in
* TclCheckExecutionTraces because for step traces,
* Tcl_CreateObjTrace creates one more linked list of traces
* which results in one more reversal of trace invocation.
*/
active.reverseScan = 1;
active.nextTracePtr = NULL;
tracePtr = iPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->level > 0 && curLevel > tracePtr->level) {
continue;
}
if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
/*
* The proc invoked might delete the traced command which
* which might try to free tracePtr. We want to use tracePtr
* until the end of this if section, so we use
* Tcl_Preserve() and Tcl_Release() to be sure it is not
* freed while we still need it.
*/
Tcl_Preserve((ClientData) tracePtr);
tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
/* New style trace */
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
TraceCommandInfo *tcmdPtr =
(TraceCommandInfo *) tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
}
traceCode = (tracePtr->proc)(tracePtr->clientData,
interp, curLevel, command, (Tcl_Command)cmdPtr,
objc, objv);
}
} else {
/* Old-style trace */
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
/*
* Old-style interpreter-wide traces only trigger
* before the command is executed.
*/
traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
command, numChars, objc, objv);
}
}
tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
Tcl_Release((ClientData) tracePtr);
}
}
iPtr->activeInterpTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* CallTraceProcedure --
*
* Invokes a trace procedure registered with an interpreter. These
* procedures trace command execution. Currently this trace procedure
* is called with the address of the string-based Tcl_CmdProc for the
* command, not the Tcl_ObjCmdProc.
*
* Results:
* None.
*
* Side effects:
* Those side effects made by the trace procedure.
*
*----------------------------------------------------------------------
*/
static int
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
register Trace *tracePtr; /* Describes the trace procedure to call. */
Command *cmdPtr; /* Points to command's Command struct. */
CONST char *command; /* Points to the first character of the
* command's source before substitutions. */
int numChars; /* The number of characters in the
* command's source. */
register int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
char *commandCopy;
int traceCode;
/*
* Copy the command characters into a new string.
*/
commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
commandCopy[numChars] = '';
/*
* Call the trace procedure then free allocated storage.
*/
traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
iPtr->numLevels, commandCopy,
(Tcl_Command) cmdPtr, objc, objv );
ckfree((char *) commandCopy);
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* CommandObjTraceDeleted --
*
* Ensure the trace is correctly deleted by decrementing its
* refCount and only deleting if no other references exist.
*
* Results:
* None.
*
* Side effects:
* May release memory.
*
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(ClientData clientData) {
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionProc --
*
* This procedure is invoked whenever code relevant to a
* 'trace execution' command is executed. It is called in one
* of two ways in Tcl's core:
*
* (i) by the TclCheckExecutionTraces, when an execution trace
* has been triggered.
* (ii) by TclCheckInterpTraces, when a prior execution trace has
* created a trace of the internals of a procedure, passing in
* this procedure as the one to be called.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* May invoke an arbitrary Tcl procedure, and may create or
* delete an interpreter-wide trace.
*
*----------------------------------------------------------------------
*/
static int
TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
int level, CONST char* command, Tcl_Command cmdInfo,
int objc, struct Tcl_Obj *CONST objv[]) {
int call = 0;
Interp *iPtr = (Interp *) interp;
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Inside any kind of execution trace callback, we do
* not allow any further execution trace callbacks to
* be called for the same trace.
*/
return traceCode;
}
if (!Tcl_InterpDeleted(interp)) {
/*
* Check whether the current call is going to eval arbitrary
* Tcl code with a generated trace, or whether we are only
* going to setup interpreter-wide traces to implement the
* 'step' traces. This latter situation can happen if
* we create a command trace without either before or after
* operations, but with either of the step operations.
*/
if (flags & TCL_TRACE_EXEC_DIRECT) {
call = flags & tcmdPtr->flags
& (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
} else {
call = 1;
}
/*
* First, if we have returned back to the level at which we
* created an interpreter trace for enterstep and/or leavestep
* execution traces, we remove it here.
*/
if (flags & TCL_TRACE_LEAVE_EXEC) {
if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)
&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
}
/*
* Second, create the tcl callback, if required.
*/
if (call) {
Tcl_SavedResult state;
int stateCode, i, saveInterpFlags;
Tcl_DString cmd;
Tcl_DString sub;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
/* Append command with arguments */
Tcl_DStringInit(&sub);
for (i = 0; i < objc; i++) {
char* str;
int len;
str = Tcl_GetStringFromObj(objv[i],&len);
Tcl_DStringAppendElement(&sub, str);
}
Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
Tcl_DStringFree(&sub);
if (flags & TCL_TRACE_ENTER_EXEC) {
/* Append trace operation */
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "enter");
} else {
Tcl_DStringAppendElement(&cmd, "enterstep");
}
} else if (flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_Obj* resultCode;
char* resultCodeStr;
/* Append result code */
resultCode = Tcl_NewIntObj(code);
resultCodeStr = Tcl_GetString(resultCode);
Tcl_DStringAppendElement(&cmd, resultCodeStr);
Tcl_DecrRefCount(resultCode);
/* Append result string */
Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));
/* Append trace operation */
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "leave");
} else {
Tcl_DStringAppendElement(&cmd, "leavestep");
}
} else {
panic("TraceExecutionProc: bad flag combination");
}
/*
* Execute the command. Save the interp's result used for
* the command, including the value of iPtr->returnCode which
* may be modified when Tcl_Eval is invoked. We discard any
* object result the command returns.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
saveInterpFlags = iPtr->flags;
iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
tcmdPtr->refCount++;
/*
* This line can have quite arbitrary side-effects,
* including deleting the trace, the command being
* traced, or even the interpreter.
*/
traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
/*
* Restore the interp tracing flag to prevent cmd traces
* from affecting interp traces
*/
iPtr->flags = saveInterpFlags;;
if (tcmdPtr->flags == 0) {
flags |= TCL_TRACE_DESTROYED;
}
if (traceCode == TCL_OK) {
/* Restore result if trace execution was successful */
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
} else {
Tcl_DiscardResult(&state);
}
Tcl_DStringFree(&cmd);
}
/*
* Third, if there are any step execution traces for this proc,
* we register an interpreter trace to invoke enterstep and/or
* leavestep traces.
* We also need to save the current stack level and the proc
* string in startLevel and startCmd so that we can delete this
* interpreter trace when it reaches the end of this proc.
*/
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
tcmdPtr->startLevel = level;
tcmdPtr->startCmd =
(char *) ckalloc((unsigned) (strlen(command) + 1));
strcpy(tcmdPtr->startCmd, command);
tcmdPtr->refCount++;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
TraceExecutionProc, (ClientData)tcmdPtr,
CommandObjTraceDeleted);
}
}
if (flags & TCL_TRACE_DESTROYED) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
}
if (call) {
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
return traceCode;
}
/*
*----------------------------------------------------------------------
*
* TraceVarProc --
*
* This procedure is called to handle variable accesses that have
* been traced using the "trace" command.
*
* Results:
* Normally returns NULL. If the trace command returns an error,
* then this procedure returns an error string.
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Information about the variable trace. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *name1; /* Name of variable or array. */
CONST char *name2; /* Name of element within array; NULL means
* scalar variable is being referenced. */
int flags; /* OR-ed bits giving operation and other
* information. */
{
Tcl_SavedResult state;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
/*
* We might call Tcl_Eval() below, and that might evaluate [trace
* vdelete] which might try to free tvarPtr. However we do not
* need to protect anything here; it's done by our caller because
* the TraceVarInfo is really part of a CompoundVarTrace. [Bug 1348775]
*/
result = NULL;
if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
if (tvarPtr->length != (size_t) 0) {
/*
* Generate a command to execute by appending list elements
* for the two variable names and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
Tcl_DStringAppend(&cmd, " a", 2);
} else if (flags & TCL_TRACE_READS) {
Tcl_DStringAppend(&cmd, " r", 2);
} else if (flags & TCL_TRACE_WRITES) {
Tcl_DStringAppend(&cmd, " w", 2);
} else if (flags & TCL_TRACE_UNSETS) {
Tcl_DStringAppend(&cmd, " u", 2);
}
} else {
#endif
if (flags & TCL_TRACE_ARRAY) {
Tcl_DStringAppend(&cmd, " array", 6);
} else if (flags & TCL_TRACE_READS) {
Tcl_DStringAppend(&cmd, " read", 5);
} else if (flags & TCL_TRACE_WRITES) {
Tcl_DStringAppend(&cmd, " write", 6);
} else if (flags & TCL_TRACE_UNSETS) {
Tcl_DStringAppend(&cmd, " unset", 6);
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
}
#endif
/*
* Execute the command. Save the interp's result used for
* the command. We discard any object result the command returns.
*
* Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
* other areas that this will be destroyed by us, otherwise a
* double-free might occur depending on what the eval does.
*/
Tcl_SaveResult(interp, &state);
if ((flags & TCL_TRACE_DESTROYED)
&& !(tvarPtr->flags & TCL_TRACE_DESTROYED)) {
destroy = 1;
tvarPtr->flags |= TCL_TRACE_DESTROYED;
}
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) { /* copy error msg to result */
register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
Tcl_RestoreResult(interp, &state);
Tcl_DStringFree(&cmd);
}
}
if (destroy) {
if (result != NULL) {
register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WhileObjCmd --
*
* This procedure is invoked to process the "while" Tcl command.
* See the user documentation for details on what it does.
*
* With the bytecode compiler, this procedure is only called when
* a command name is computed at runtime, and is "while" or the name
* to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
while (1) {
result = Tcl_ExprBooleanObj(interp, objv[1], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[2], 0);
#else
/* TIP #280. */
result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2);
#endif
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "n ("while" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
}
if (result == TCL_BREAK) {
result = TCL_OK;
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
#ifdef TCL_TIP280
static void
ListLines(listStr, line, n, lines)
CONST char* listStr; /* Pointer to string with list structure.
* Assumed to be valid. Assumed to contain
* n elements.
*/
int line; /* line the list as a whole starts on */
int n; /* #elements in lines */
int* lines; /* Array of line numbers, to fill */
{
int i;
int length = strlen( listStr);
CONST char *element = NULL;
CONST char* next = NULL;
for (i = 0; i < n; i++) {
TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);
TclAdvanceLines (&line, listStr, element); /* Leading whitespace */
lines [i] = line;
length -= (next - listStr);
TclAdvanceLines (&line, element, next); /* Element */
listStr = next;
if (*element == 0) {
/* ASSERT i == n */
break;
}
}
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/