source: downloads/tcl8.5.2/generic/tclTrace.c @ 64

/*
 * tclTrace.c --
 *
 *      This file contains code to handle most trace management.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTrace.c,v 1.47 2007/12/13 15:23:20 dgp Exp $
 */

#include "tclInt.h"

/*
 * Structures used to hold information about variable traces:
 */

typedef struct {
    int flags;                  /* Operations for which Tcl command is to be
                                 * invoked. */
    size_t length;              /* Number of non-NUL chars. in command. */
    char command[4];            /* Space for Tcl command to invoke. Actual
                                 * size will be as large as necessary to hold
                                 * command. This field must be the last in the
                                 * structure, so that it can be larger than 4
                                 * bytes. */
} TraceVarInfo;

typedef struct {
    VarTrace traceInfo;
    TraceVarInfo traceCmdInfo;
} CombinedTraceVarInfo;

/*
 * Structure used to hold information about command traces:
 */

typedef struct {
    int flags;                  /* Operations for which Tcl command is to be
                                 * invoked. */
    size_t length;              /* Number of non-NUL chars. in command. */
    Tcl_Trace stepTrace;        /* Used for execution traces, when tracing
                                 * inside the given command */
    int startLevel;             /* Used for bookkeeping with step execution
                                 * traces, store the level at which the step
                                 * trace was invoked */
    char *startCmd;             /* Used for bookkeeping with step execution
                                 * traces, store the command name which
                                 * invoked step trace */
    int curFlags;               /* Trace flags for the current command */
    int curCode;                /* Return code for the current command */
    int refCount;               /* Used to ensure this structure is not
                                 * deleted too early. Keeps track of how many
                                 * pieces of code have a pointer to this
                                 * structure. */
    char command[4];            /* Space for Tcl command to invoke. Actual
                                 * size will be as large as necessary to hold
                                 * command. This field must be the last in the
                                 * structure, so that it can be larger than 4
                                 * bytes. */
} TraceCommandInfo;

/*
 * Used by command execution traces. Note that we assume in the code that
 * TCL_TRACE_ENTER_DURING_EXEC == 4 * TCL_TRACE_ENTER_EXEC and that
 * TCL_TRACE_LEAVE_DURING_EXEC == 4 * TCL_TRACE_LEAVE_EXEC.
 *
 * TCL_TRACE_ENTER_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, before execution.
 * TCL_TRACE_LEAVE_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, after execution.
 * TCL_TRACE_ANY_EXEC           - OR'd combination of all EXEC flags.
 * TCL_TRACE_EXEC_IN_PROGRESS   - The callback function on this trace is
 *                                currently executing. Therefore we don't let
 *                                further traces execute.
 * TCL_TRACE_EXEC_DIRECT        - This execution trace is triggered directly
 *                                by the command being traced, not because of
 *                                an internal trace.
 * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used
 * in command execution traces.
 */

#define TCL_TRACE_ENTER_DURING_EXEC     4
#define TCL_TRACE_LEAVE_DURING_EXEC     8
#define TCL_TRACE_ANY_EXEC              15
#define TCL_TRACE_EXEC_IN_PROGRESS      0x10
#define TCL_TRACE_EXEC_DIRECT           0x20

/*
 * Forward declarations for functions defined in this file:
 */

typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex,
        int objc, Tcl_Obj *const objv[]);

static Tcl_TraceTypeObjCmd TraceVariableObjCmd;
static Tcl_TraceTypeObjCmd TraceCommandObjCmd;
static Tcl_TraceTypeObjCmd TraceExecutionObjCmd;

/*
 * Each subcommand has a number of 'types' to which it can apply. Currently
 * 'execution', 'command' and 'variable' are the only types supported. These
 * three arrays MUST be kept in sync! In the future we may provide an API to
 * add to the list of supported trace types.
 */

static const char *traceTypeOptions[] = {
    "execution", "command", "variable", NULL
};
static Tcl_TraceTypeObjCmd *traceSubCmds[] = {
    TraceExecutionObjCmd,
    TraceCommandObjCmd,
    TraceVariableObjCmd,
};

/*
 * Declarations for local functions to this file:
 */

static int              CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr,
                            Command *cmdPtr, const char *command, int numChars,
                            int objc, Tcl_Obj *const objv[]);
static char *           TraceVarProc(ClientData clientData, Tcl_Interp *interp,
                            const char *name1, const char *name2, int flags);
static void             TraceCommandProc(ClientData clientData,
                            Tcl_Interp *interp, const char *oldName,
                            const char *newName, int flags);
static Tcl_CmdObjTraceProc TraceExecutionProc;
static int              StringTraceProc(ClientData clientData,
                            Tcl_Interp *interp, int level,
                            const char *command, Tcl_Command commandInfo,
                            int objc, Tcl_Obj *const objv[]);
static void             StringTraceDeleteProc(ClientData clientData);
static void             DisposeTraceResult(int flags, char *result);
static int              TraceVarEx(Tcl_Interp *interp, const char *part1,
                            const char *part2, register VarTrace *tracePtr);

/*
 * The following structure holds the client data for string-based
 * trace procs
 */

typedef struct StringTraceData {
    ClientData clientData;      /* Client data from Tcl_CreateTrace */
    Tcl_CmdTraceProc *proc;     /* Trace function from Tcl_CreateTrace */
} StringTraceData;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceObjCmd --
 *
 *      This function 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(
    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
        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: {
        /*
         * 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);
    }
    case TRACE_INFO: {
        /*
         * All sub commands of trace info must take exactly two more arguments
         * which name the type of thing being traced and the name of the thing
         * being traced.
         */

        int typeIndex;
        if (objc < 3) {
            /*
             * Delegate other complaints to the type-specific code which can
             * give a better error message.
             */

            Tcl_WrongNumArgs(interp, 2, objv, "type name");
            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);
        break;
    }

#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++) {
            Tcl_Obj *opObj;

            if (*p == 'r') {
                TclNewLiteralStringObj(opObj, "read");
            } else if (*p == 'w') {
                TclNewLiteralStringObj(opObj, "write");
            } else if (*p == 'u') {
                TclNewLiteralStringObj(opObj, "unset");
            } else if (*p == 'a') {
                TclNewLiteralStringObj(opObj, "array");
            } else {
                Tcl_DecrRefCount(opsList);
                goto badVarOps;
            }
            Tcl_ListObjAppendElement(NULL, opsList, opObj);
        }
        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_NewObj();
        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, 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 = '\0';

            /*
             * 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", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceExecutionObjCmd --
 *
 *      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.
 *
 *----------------------------------------------------------------------
 */

static int
TraceExecutionObjCmd(
    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", 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;
                    }
                    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, NULL);
        while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
                TraceCommandProc, clientData)) != NULL) {
            int numOps = 0;
            Tcl_Obj *opObj;
            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, NULL);
            Tcl_IncrRefCount(elemObjPtr);
            if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
                TclNewLiteralStringObj(opObj, "enter");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
                TclNewLiteralStringObj(opObj, "leave");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
                TclNewLiteralStringObj(opObj, "enterstep");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
                TclNewLiteralStringObj(opObj, "leavestep");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
            if (0 == numOps) {
                Tcl_DecrRefCount(elemObjPtr);
                continue;
            }
            eachTraceObjPtr = Tcl_NewListObj(0, 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;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceCommandObjCmd --
 *
 *      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.
 *
 *----------------------------------------------------------------------
 */

static int
TraceCommandObjCmd(
    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", 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;
                    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, NULL);
        while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
                TraceCommandProc, clientData)) != NULL) {
            int numOps = 0;
            Tcl_Obj *opObj;
            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, NULL);
            Tcl_IncrRefCount(elemObjPtr);
            if (tcmdPtr->flags & TCL_TRACE_RENAME) {
                TclNewLiteralStringObj(opObj, "rename");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            if (tcmdPtr->flags & TCL_TRACE_DELETE) {
                TclNewLiteralStringObj(opObj, "delete");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
            if (0 == numOps) {
                Tcl_DecrRefCount(elemObjPtr);
                continue;
            }
            eachTraceObjPtr = Tcl_NewListObj(0, 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;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVariableObjCmd --
 *
 *      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.
 *
 *----------------------------------------------------------------------
 */

static int
TraceVariableObjCmd(
    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", 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) {
            CombinedTraceVarInfo *ctvarPtr;

            ctvarPtr = (CombinedTraceVarInfo *) ckalloc((unsigned)
                    (sizeof(CombinedTraceVarInfo) + length + 1
                    - sizeof(ctvarPtr->traceCmdInfo.command)));
            ctvarPtr->traceCmdInfo.flags = flags;
            if (objv[0] == NULL) {
                ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
            }
            ctvarPtr->traceCmdInfo.length = length;
            flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
            strcpy(ctvarPtr->traceCmdInfo.command, command);
            ctvarPtr->traceInfo.traceProc = TraceVarProc;
            ctvarPtr->traceInfo.clientData = (ClientData)
                    &ctvarPtr->traceCmdInfo;
            ctvarPtr->traceInfo.flags = flags;
            name = Tcl_GetString(objv[3]);
            if (TraceVarEx(interp,name,NULL,(VarTrace*)ctvarPtr) != TCL_OK) {
                ckfree((char *) ctvarPtr);
                return TCL_ERROR;
            }
        } 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_NewObj();
        clientData = 0;
        name = Tcl_GetString(objv[3]);
        while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc,
                clientData)) != 0) {
            Tcl_Obj *opObj;
            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, NULL);
            if (tvarPtr->flags & TCL_TRACE_ARRAY) {
                TclNewLiteralStringObj(opObj, "array");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            if (tvarPtr->flags & TCL_TRACE_READS) {
                TclNewLiteralStringObj(opObj, "read");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            if (tvarPtr->flags & TCL_TRACE_WRITES) {
                TclNewLiteralStringObj(opObj, "write");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            if (tvarPtr->flags & TCL_TRACE_UNSETS) {
                TclNewLiteralStringObj(opObj, "unset");
                Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
            }
            eachTraceObjPtr = Tcl_NewListObj(0, 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 function can also be used to step through all of the traces on a
 *      particular command that have the same trace function.
 *
 * 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 function. 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(
    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, /* Function assocated with trace. */
    ClientData prevClientData)  /* If non-NULL, gives last value returned by
                                 * this function, 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 function to be
 *      invoked, which can monitor the operations.
 *
 *      Also optionally arrange for execution of that command to cause a
 *      function 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(
    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, /* Function to call when specified ops are
                                 * invoked upon cmdName. */
    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(
    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, /* Function 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 function 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 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. */
{
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
    int code;
    Tcl_DString cmd;

    tcmdPtr->refCount++;

    if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)
            && !Tcl_LimitExceeded(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. 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.
         */

        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 */
            /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/
        }
        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;
        Tcl_InterpState state;

        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.
         */

        state = Tcl_SaveInterpState(interp, TCL_OK);
        Tcl_UntraceCommand(interp, oldName, untraceFlags,
                TraceCommandProc, clientData);
        (void) Tcl_RestoreInterpState(interp, state);
        tcmdPtr->refCount--;
    }
    if ((--tcmdPtr->refCount) <= 0) {
        ckfree((char *) tcmdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckExecutionTraces --
 *
 *      Checks on all current command execution traces, and invokes functions
 *      which have been registered. This function 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 function 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 functions called.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckExecutionTraces(
    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;
    Tcl_InterpState state = NULL;

    if (cmdPtr->tracePtr == NULL) {
        return traceCode;
    }

    curLevel = 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) {
            TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
                    tracePtr->clientData;

            if (tcmdPtr->flags != 0) {
                tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
                tcmdPtr->curCode  = code;
                tcmdPtr->refCount++;
                if (state == NULL) {
                    state = Tcl_SaveInterpState(interp, code);
                }
                traceCode = TraceExecutionProc((ClientData) tcmdPtr, interp,
                        curLevel, command, (Tcl_Command) cmdPtr, objc, objv);
                if ((--tcmdPtr->refCount) <= 0) {
                    ckfree((char *) tcmdPtr);
                }
            }
        }
        if (active.nextTracePtr) {
            lastTracePtr = active.nextTracePtr->nextPtr;
        }
    }
    iPtr->activeCmdTracePtr = active.nextPtr;
    if (state) {
        (void) Tcl_RestoreInterpState(interp, state);
    }

    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckInterpTraces --
 *
 *      Checks on all current traces, and invokes functions which have been
 *      registered. This function 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 function 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 functions called.
 *
 *----------------------------------------------------------------------
 */

int
TclCheckInterpTraces(
    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;
    Tcl_InterpState state = NULL;

    if ((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 (state == NULL) {
                state = Tcl_SaveInterpState(interp, code);
            }

            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 = CallTraceFunction(interp, tracePtr, cmdPtr,
                            command, numChars, objc, objv);
                }
            }
            tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
            Tcl_Release((ClientData) tracePtr);
        }
    }
    iPtr->activeInterpTracePtr = active.nextPtr;
    if (state) {
        if (traceCode == TCL_OK) {
            (void) Tcl_RestoreInterpState(interp, state);
        } else {
            Tcl_DiscardInterpState(state);
        }
    }

    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * CallTraceFunction --
 *
 *      Invokes a trace function registered with an interpreter. These
 *      functions trace command execution. Currently this trace function 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 function.
 *
 *----------------------------------------------------------------------
 */

static int
CallTraceFunction(
    Tcl_Interp *interp,         /* The current interpreter. */
    register Trace *tracePtr,   /* Describes the trace function 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 = TclStackAlloc(interp, (unsigned) (numChars + 1));
    memcpy(commandCopy, command, (size_t) numChars);
    commandCopy[numChars] = '\0';

    /*
     * Call the trace function then free allocated storage.
     */

    traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp *) iPtr,
            iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv);

    TclStackFree(interp, 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;

    if ((--tcmdPtr->refCount) <= 0) {
        ckfree((char *) tcmdPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TraceExecutionProc --
 *
 *      This function 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 function 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) && !Tcl_LimitExceeded(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) && (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_DString cmd;
            Tcl_DString sub;
            int i, saveInterpFlags;

            Tcl_DStringInit(&cmd);
            Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);

            /*
             * Append command with arguments.
             */

            Tcl_DStringInit(&sub);
            for (i = 0; i < objc; i++) {
                Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i]));
            }
            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 {
                Tcl_Panic("TraceExecutionProc: bad flag combination");
            }

            /*
             * Execute the command. We discard any object result the command
             * returns.
             */

            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;
            }
            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))) {
            register unsigned len = strlen(command) + 1;

            tcmdPtr->startLevel = level;
            tcmdPtr->startCmd = ckalloc(len);
            memcpy(tcmdPtr->startCmd, command, len);
            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(tcmdPtr->startCmd);
            }
        }
    }
    if (call) {
        if ((--tcmdPtr->refCount) <= 0) {
            ckfree((char *) tcmdPtr);
        }
    }
    return traceCode;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *      This function 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 function returns an error string.
 *
 * Side effects:
 *      Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
static char *
TraceVarProc(
    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. */
{
    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. We want to use tvarPtr until the end
     * of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure
     * it is not freed while we still need it.
     */

    result = NULL;
    if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)
            && !Tcl_LimitExceeded(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. 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.
             */

            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 */
                Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
                Tcl_IncrRefCount(errMsgObj);
                result = (char *) errMsgObj;
            }
            Tcl_DStringFree(&cmd);
        }
    }
    if (destroy && result != NULL) {
        register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;

        Tcl_DecrRefCount(errMsgObj);
        result = NULL;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateObjTrace --
 *
 *      Arrange for a function 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 function 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' function will be invoked,
 *      passing it the original client data.
 *
 *----------------------------------------------------------------------
 */

Tcl_Trace
Tcl_CreateObjTrace(
    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)
                                /* Function 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 function 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 function. 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 function 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(
    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,     /* Function to call before executing each
                                 * command. */
    ClientData clientData)      /* Arbitrary value word to pass to proc. */
{
    StringTraceData *data = (StringTraceData *)
            ckalloc(sizeof(StringTraceData));

    data->clientData = clientData;
    data->proc = proc;
    return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc,
            (ClientData) data, StringTraceDeleteProc);
}

/*
 *----------------------------------------------------------------------
 *
 * StringTraceProc --
 *
 *      Invoke a string-based trace function from an object-based callback.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Whatever the string-based trace function does.
 *
 *----------------------------------------------------------------------
 */

static int
StringTraceProc(
    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 **) TclStackAlloc(interp,
            (unsigned) ((objc + 1) * sizeof(const char *)));
    for (i = 0; i < objc; i++) {
        argv[i] = Tcl_GetString(objv[i]);
    }
    argv[objc] = 0;

    /*
     * Invoke the command function. 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);
    TclStackFree(interp, (void *) 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)
{
    ckfree((char *) clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteTrace --
 *
 *      Remove a trace.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      From now on there will be no more calls to the function given in
 *      trace.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteTrace(
    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);
}

/*
 *----------------------------------------------------------------------
 *
 * TclTraceVarExists --
 *
 *      This is called from info exists. We need to trigger read and/or array
 *      traces because they may end up creating a variable that doesn't
 *      currently exist.
 *
 * Results:
 *      A pointer to the Var structure, or NULL.
 *
 * Side effects:
 *      May fill in error messages in the interp.
 *
 *----------------------------------------------------------------------
 */

Var *
TclVarTraceExists(
    Tcl_Interp *interp,         /* The interpreter */
    const char *varName)        /* The variable name */
{
    Var *varPtr;
    Var *arrayPtr;

    /*
     * The choice of "create" flag values is delicate here, and matches the
     * semantics of GetVar. Things are still not perfect, however, because if
     * you do "info exists x" you get a varPtr and therefore trigger traces.
     * However, if you do "info exists x(i)", then you only get a varPtr if x
     * is already known to be an array. Otherwise you get NULL, and no trace
     * is triggered. This matches Tcl 7.6 semantics.
     */

    varPtr = TclLookupVar(interp, varName, NULL, 0, "access",
            /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);

    if (varPtr == NULL) {
        return NULL;
    }

    if ((varPtr->flags & VAR_TRACED_READ)
            || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) {
        TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
                TCL_TRACE_READS, /* leaveErrMsg */ 0);
    }

    /*
     * If the variable doesn't exist anymore and no-one's using it, then free
     * up the relevant structures and hash table entries.
     */

    if (TclIsVarUndefined(varPtr)) {
        TclCleanupVar(varPtr, arrayPtr);
        return NULL;
    }

    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCallVarTraces --
 *
 *      This function is invoked to find and invoke relevant trace functions
 *      associated with a particular operation on a variable. This function
 *      invokes traces both on the variable and on its containing array (where
 *      relevant).
 *
 * Results:
 *      Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if
 *      invocation of a trace function indicated an error. When TCL_ERROR is
 *      returned and leaveErrMsg is true, then the errorInfo field of iPtr has
 *      information about the error placed in it.
 *
 * Side effects:
 *      Almost anything can happen, depending on trace; this function itself
 *      doesn't have any side effects.
 *
 *----------------------------------------------------------------------
 */

int
TclObjCallVarTraces(
    Interp *iPtr,               /* Interpreter containing variable. */
    register Var *arrayPtr,     /* Pointer to array variable that contains the
                                 * variable, or NULL if the variable isn't an
                                 * element of an array. */
    Var *varPtr,                /* Variable whose traces are to be invoked. */
    Tcl_Obj *part1Ptr,
    Tcl_Obj *part2Ptr,          /* Variable's two-part name. */
    int flags,                  /* Flags passed to trace functions: indicates
                                 * what's happening to variable, plus maybe
                                 * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */
    int leaveErrMsg,            /* If true, and one of the traces indicates an
                                 * error, then leave an error message and
                                 * stack trace information in *iPTr. */
    int index)                  /* Index into the local variable table of the
                                 * variable, or -1. Only used when part1Ptr is
                                 * NULL. */
{
    char *part1, *part2;

    if (!part1Ptr) {
        part1Ptr = localName(iPtr->varFramePtr, index);
    }
    part1 = TclGetString(part1Ptr);
    part2 = part2Ptr? TclGetString(part2Ptr) : NULL;

    return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags,
            leaveErrMsg);
}

int
TclCallVarTraces(
    Interp *iPtr,               /* Interpreter containing variable. */
    register Var *arrayPtr,     /* Pointer to array variable that contains the
                                 * variable, or NULL if the variable isn't an
                                 * element of an array. */
    Var *varPtr,                /* Variable whose traces are to be invoked. */
    const char *part1,
    const char *part2,          /* Variable's two-part name. */
    int flags,                  /* Flags passed to trace functions: indicates
                                 * what's happening to variable, plus maybe
                                 * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */
    int leaveErrMsg)            /* If true, and one of the traces indicates an
                                 * error, then leave an error message and
                                 * stack trace information in *iPTr. */
{
    register VarTrace *tracePtr;
    ActiveVarTrace active;
    char *result;
    const char *openParen, *p;
    Tcl_DString nameCopy;
    int copiedName;
    int code = TCL_OK;
    int disposeFlags = 0;
    Tcl_InterpState state = NULL;
    Tcl_HashEntry *hPtr;
    int traceflags = flags & VAR_ALL_TRACES;

    /*
     * If there are already similar trace functions active for the variable,
     * don't call them again.
     */

    if (TclIsVarTraceActive(varPtr)) {
        return code;
    }
    TclSetVarTraceActive(varPtr);
    if (TclIsVarInHash(varPtr)) {
        VarHashRefCount(varPtr)++;
    }
    if (arrayPtr && TclIsVarInHash(arrayPtr)) {
        VarHashRefCount(arrayPtr)++;
    }

    /*
     * If the variable name hasn't been parsed into array name and element, do
     * it here. If there really is an array element, make a copy of the
     * original name so that NULLs can be inserted into it to separate the
     * names (can't modify the name string in place, because the string might
     * get used by the callbacks we invoke).
     */

    copiedName = 0;
    if (part2 == NULL) {
        for (p = part1; *p ; p++) {
            if (*p == '(') {
                openParen = p;
                do {
                    p++;
                } while (*p != '\0');
                p--;
                if (*p == ')') {
                    int offset = (openParen - part1);
                    char *newPart1;

                    Tcl_DStringInit(&nameCopy);
                    Tcl_DStringAppend(&nameCopy, part1, (p-part1));
                    newPart1 = Tcl_DStringValue(&nameCopy);
                    newPart1[offset] = 0;
                    part1 = newPart1;
                    part2 = newPart1 + offset + 1;
                    copiedName = 1;
                }
                break;
            }
        }
    }

    /*
     * Ignore any caller-provided TCL_INTERP_DESTROYED flag.  Only we can
     * set it correctly.
     */

    flags &= ~TCL_INTERP_DESTROYED;

    /*
     * Invoke traces on the array containing the variable, if relevant.
     */

    result = NULL;
    active.nextPtr = iPtr->activeVarTracePtr;
    iPtr->activeVarTracePtr = &active;
    Tcl_Preserve((ClientData) iPtr);
    if (arrayPtr && !TclIsVarTraceActive(arrayPtr)
            && (arrayPtr->flags & traceflags)) {
        hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr);
        active.varPtr = arrayPtr;
        for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
             tracePtr != NULL; tracePtr = active.nextTracePtr) {
            active.nextTracePtr = tracePtr->nextPtr;
            if (!(tracePtr->flags & flags)) {
                continue;
            }
            Tcl_Preserve((ClientData) tracePtr);
            if (state == NULL) {
                state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
            }
            if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
                flags |= TCL_INTERP_DESTROYED;
            }
            result = (*tracePtr->traceProc)(tracePtr->clientData,
                    (Tcl_Interp *) iPtr, part1, part2, flags);
            if (result != NULL) {
                if (flags & TCL_TRACE_UNSETS) {
                    /*
                     * Ignore errors in unset traces.
                     */

                    DisposeTraceResult(tracePtr->flags, result);
                } else {
                    disposeFlags = tracePtr->flags;
                    code = TCL_ERROR;
                }
            }
            Tcl_Release((ClientData) tracePtr);
            if (code == TCL_ERROR) {
                goto done;
            }
        }
    }

    /*
     * Invoke traces on the variable itself.
     */

    if (flags & TCL_TRACE_UNSETS) {
        flags |= TCL_TRACE_DESTROYED;
    }
    active.varPtr = varPtr;
    if (varPtr->flags & traceflags) {
        hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
        for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
             tracePtr != NULL; tracePtr = active.nextTracePtr) {
            active.nextTracePtr = tracePtr->nextPtr;
            if (!(tracePtr->flags & flags)) {
                continue;
            }
            Tcl_Preserve((ClientData) tracePtr);
            if (state == NULL) {
                state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
            }
            if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
                flags |= TCL_INTERP_DESTROYED;
            }
            result = (*tracePtr->traceProc)(tracePtr->clientData,
                    (Tcl_Interp *) iPtr, part1, part2, flags);
            if (result != NULL) {
                if (flags & TCL_TRACE_UNSETS) {
                    /*
                     * Ignore errors in unset traces.
                     */

                    DisposeTraceResult(tracePtr->flags, result);
                } else {
                    disposeFlags = tracePtr->flags;
                    code = TCL_ERROR;
                }
            }
            Tcl_Release((ClientData) tracePtr);
            if (code == TCL_ERROR) {
                goto done;
            }
        }
    }

    /*
     * Restore the variable's flags, remove the record of our active traces,
     * and then return.
     */

  done:
    if (code == TCL_ERROR) {
        if (leaveErrMsg) {
            const char *type = "";
            Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code);
            Tcl_Obj *errorInfoKey, *errorInfo;

            TclNewLiteralStringObj(errorInfoKey, "-errorinfo");
            Tcl_IncrRefCount(errorInfoKey);
            Tcl_DictObjGet(NULL, options, errorInfoKey, &errorInfo);
            Tcl_IncrRefCount(errorInfo);
            Tcl_DictObjRemove(NULL, options, errorInfoKey);
            if (Tcl_IsShared(errorInfo)) {
                Tcl_DecrRefCount(errorInfo);
                errorInfo = Tcl_DuplicateObj(errorInfo);
                Tcl_IncrRefCount(errorInfo);
            }
            Tcl_AppendToObj(errorInfo, "\n    (", -1);
            switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
            case TCL_TRACE_READS:
                type = "read";
                Tcl_AppendToObj(errorInfo, type, -1);
                break;
            case TCL_TRACE_WRITES:
                type = "set";
                Tcl_AppendToObj(errorInfo, "write", -1);
                break;
            case TCL_TRACE_ARRAY:
                type = "trace array";
                Tcl_AppendToObj(errorInfo, "array", -1);
                break;
            }
            if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
                TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
                        Tcl_GetString((Tcl_Obj *) result));
            } else {
                TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
            }
            Tcl_AppendToObj(errorInfo, " trace on \"", -1);
            Tcl_AppendToObj(errorInfo, part1, -1);
            if (part2 != NULL) {
                Tcl_AppendToObj(errorInfo, "(", -1);
                Tcl_AppendToObj(errorInfo, part1, -1);
                Tcl_AppendToObj(errorInfo, ")", -1);
            }
            Tcl_AppendToObj(errorInfo, "\")", -1);
            Tcl_DictObjPut(NULL, options, errorInfoKey, errorInfo);
            Tcl_DecrRefCount(errorInfoKey);
            Tcl_DecrRefCount(errorInfo);
            code = Tcl_SetReturnOptions((Tcl_Interp *)iPtr, options);
            iPtr->flags &= ~(ERR_ALREADY_LOGGED);
            Tcl_DiscardInterpState(state);
        } else {
            (void) Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state);
        }
        DisposeTraceResult(disposeFlags,result);
    } else if (state) {
        if (code == TCL_OK) {
            code = Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state);
        } else {
            Tcl_DiscardInterpState(state);
        }
    }

    if (arrayPtr && TclIsVarInHash(arrayPtr)) {
        VarHashRefCount(arrayPtr)--;
    }
    if (copiedName) {
        Tcl_DStringFree(&nameCopy);
    }
    TclClearVarTraceActive(varPtr);
    if (TclIsVarInHash(varPtr)) {
        VarHashRefCount(varPtr)--;
    }
    iPtr->activeVarTracePtr = active.nextPtr;
    Tcl_Release((ClientData) iPtr);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * DisposeTraceResult--
 *
 *      This function is called to dispose of the result returned from a trace
 *      function. The disposal method appropriate to the type of result is
 *      determined by flags.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The memory allocated for the trace result may be freed.
 *
 *----------------------------------------------------------------------
 */

static void
DisposeTraceResult(
    int flags,                  /* Indicates type of result to determine
                                 * proper disposal method. */
    char *result)               /* The result returned from a trace function
                                 * to be disposed. */
{
    if (flags & TCL_TRACE_RESULT_DYNAMIC) {
        ckfree(result);
    } else if (flags & TCL_TRACE_RESULT_OBJECT) {
        Tcl_DecrRefCount((Tcl_Obj *) result);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceVar --
 *
 *      Remove a previously-created trace for a variable.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      If there exists a trace for the variable given by varName with the
 *      given flags, proc, and clientData, then that trace is removed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar(
    Tcl_Interp *interp,         /* Interpreter containing variable. */
    const char *varName,        /* Name of variable; may end with "(index)" to
                                 * signify an array reference. */
    int flags,                  /* OR-ed collection of bits describing current
                                 * trace, including any of TCL_TRACE_READS,
                                 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
                                 * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,     /* Function assocated with trace. */
    ClientData clientData)      /* Arbitrary argument to pass to proc. */
{
    Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceVar2 --
 *
 *      Remove a previously-created trace for a variable.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      If there exists a trace for the variable given by part1 and part2 with
 *      the given flags, proc, and clientData, then that trace is removed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar2(
    Tcl_Interp *interp,         /* Interpreter containing variable. */
    const char *part1,          /* Name of variable or array. */
    const char *part2,          /* Name of element within array; NULL means
                                 * trace applies to scalar variable or array
                                 * as-a-whole. */
    int flags,                  /* OR-ed collection of bits describing current
                                 * trace, including any of TCL_TRACE_READS,
                                 * TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
                                 * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,     /* Function assocated with trace. */
    ClientData clientData)      /* Arbitrary argument to pass to proc. */
{
    register VarTrace *tracePtr;
    VarTrace *prevPtr, *nextPtr;
    Var *varPtr, *arrayPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveVarTrace *activePtr;
    int flagMask, allFlags = 0;
    Tcl_HashEntry *hPtr;

    /*
     * Set up a mask to mask out the parts of the flags that we are not
     * interested in now.
     */

    flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
    varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ NULL,
            /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL || !(varPtr->flags & VAR_ALL_TRACES & flags)) {
        return;
    }

    /*
     * Set up a mask to mask out the parts of the flags that we are not
     * interested in now.
     */

    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
    flags &= flagMask;

    hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
            (char *) varPtr);
    for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
            prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
        if (tracePtr == NULL) {
            goto updateFlags;
        }
        if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
                && (tracePtr->clientData == clientData)) {
            break;
        }
        allFlags |= tracePtr->flags;
    }

    /*
     * 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
     * TclCallVarTraces.
     */

    for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
            activePtr = activePtr->nextPtr) {
        if (activePtr->nextTracePtr == tracePtr) {
            activePtr->nextTracePtr = tracePtr->nextPtr;
        }
    }
    nextPtr = tracePtr->nextPtr;
    if (prevPtr == NULL) {
        if (nextPtr) {
            Tcl_SetHashValue(hPtr, nextPtr);
        } else {
            Tcl_DeleteHashEntry(hPtr);
        }
    } else {
        prevPtr->nextPtr = nextPtr;
    }
    Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);

    for (tracePtr = nextPtr; tracePtr != NULL;
            tracePtr = tracePtr->nextPtr) {
        allFlags |= tracePtr->flags;
    }

  updateFlags:
    varPtr->flags &= ~VAR_ALL_TRACES;
    if (allFlags & VAR_ALL_TRACES) {
        varPtr->flags |= (allFlags & VAR_ALL_TRACES);
    } else if (TclIsVarUndefined(varPtr)) {
        /*
         * If this is the last trace on the variable, and the variable is
         * unset and unused, then free up the variable.
         */

        TclCleanupVar(varPtr, NULL);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarTraceInfo --
 *
 *      Return the clientData value associated with a trace on a variable.
 *      This function can also be used to step through all of the traces on a
 *      particular variable that have the same trace function.
 *
 * Results:
 *      The return value is the clientData value associated with a trace on
 *      the given variable. Information will only be returned for a trace with
 *      proc as trace function. 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 variable doesn't
 *      exist, or if there are no (more) traces for it, then NULL is returned.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo(
    Tcl_Interp *interp,         /* Interpreter containing variable. */
    const char *varName,        /* Name of variable; may end with "(index)" to
                                 * signify an array reference. */
    int flags,                  /* OR-ed combo or TCL_GLOBAL_ONLY,
                                 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_VarTraceProc *proc,     /* Function assocated with trace. */
    ClientData prevClientData)  /* If non-NULL, gives last value returned by
                                 * this function, so this call will return the
                                 * next trace after that one. If NULL, this
                                 * call will return the first trace. */
{
    return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
            prevClientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarTraceInfo2 --
 *
 *      Same as Tcl_VarTraceInfo, except takes name in two pieces instead of
 *      one.
 *
 * Results:
 *      Same as Tcl_VarTraceInfo.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo2(
    Tcl_Interp *interp,         /* Interpreter containing variable. */
    const char *part1,          /* Name of variable or array. */
    const char *part2,          /* Name of element within array; NULL means
                                 * trace applies to scalar variable or array
                                 * as-a-whole. */
    int flags,                  /* OR-ed combination of TCL_GLOBAL_ONLY,
                                 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,     /* Function assocated with trace. */
    ClientData prevClientData)  /* If non-NULL, gives last value returned by
                                 * this function, so this call will return the
                                 * next trace after that one. If NULL, this
                                 * call will return the first trace. */
{
    Interp *iPtr = (Interp *) interp;
    register VarTrace *tracePtr;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;

    varPtr = TclLookupVar(interp, part1, part2,
            flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ NULL,
            /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
        return NULL;
    }

    /*
     * Find the relevant trace, if any, and return its clientData.
     */

    hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
            (char *) varPtr);

    if (hPtr) {
        tracePtr = Tcl_GetHashValue(hPtr);

        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_TraceVar --
 *
 *      Arrange for reads and/or writes to a variable to cause a function to
 *      be invoked, which can monitor the operations and/or change their
 *      actions.
 *
 * Results:
 *      A standard Tcl return value.
 *
 * Side effects:
 *      A trace is set up on the variable given by varName, such that future
 *      references to the variable will be intermediated by proc. See the
 *      manual entry for complete details on the calling sequence for proc.
 *     The variable's flags are updated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar(
    Tcl_Interp *interp,         /* Interpreter in which variable is to be
                                 * traced. */
    const char *varName,        /* Name of variable; may end with "(index)" to
                                 * signify an array reference. */
    int flags,                  /* OR-ed collection of bits, including any of
                                 * TCL_TRACE_READS, TCL_TRACE_WRITES,
                                 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
                                 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,     /* Function to call when specified ops are
                                 * invoked upon varName. */
    ClientData clientData)      /* Arbitrary argument to pass to proc. */
{
    return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceVar2 --
 *
 *      Arrange for reads and/or writes to a variable to cause a function to
 *      be invoked, which can monitor the operations and/or change their
 *      actions.
 *
 * Results:
 *      A standard Tcl return value.
 *
 * Side effects:
 *      A trace is set up on the variable given by part1 and part2, such that
 *      future references to the variable will be intermediated by proc. See
 *      the manual entry for complete details on the calling sequence for
 *      proc. The variable's flags are updated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar2(
    Tcl_Interp *interp,         /* Interpreter in which variable is to be
                                 * traced. */
    const char *part1,          /* Name of scalar variable or array. */
    const char *part2,          /* Name of element within array; NULL means
                                 * trace applies to scalar variable or array
                                 * as-a-whole. */
    int flags,                  /* OR-ed collection of bits, including any of
                                 * TCL_TRACE_READS, TCL_TRACE_WRITES,
                                 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
                                 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc,     /* Function to call when specified ops are
                                 * invoked upon varName. */
    ClientData clientData)      /* Arbitrary argument to pass to proc. */
{
    register VarTrace *tracePtr;
    int result;

    tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags;

    result = TraceVarEx(interp, part1, part2, tracePtr);

    if (result != TCL_OK) {
        ckfree((char *) tracePtr);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarEx --
 *
 *      Arrange for reads and/or writes to a variable to cause a function to
 *      be invoked, which can monitor the operations and/or change their
 *      actions.
 *
 * Results:
 *      A standard Tcl return value.
 *
 * Side effects:
 *      A trace is set up on the variable given by part1 and part2, such that
 *      future references to the variable will be intermediated by the
 *      traceProc listed in tracePtr. See the manual entry for complete
 *      details on the calling sequence for proc.
 *
 *----------------------------------------------------------------------
 */

static int
TraceVarEx(
    Tcl_Interp *interp,         /* Interpreter in which variable is to be
                                 * traced. */
    const char *part1,          /* Name of scalar variable or array. */
    const char *part2,          /* Name of element within array; NULL means
                                 * trace applies to scalar variable or array
                                 * as-a-whole. */
    register VarTrace *tracePtr)/* Structure containing flags, traceProc and
                                 * clientData fields. Others should be left
                                 * blank. Will be ckfree()d (eventually) if
                                 * this function returns TCL_OK, and up to
                                 * caller to free if this function returns
                                 * TCL_ERROR. */
{
    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    int flagMask, isNew;
    Tcl_HashEntry *hPtr;

    /*
     * We strip 'flags' down to just the parts which are relevant to
     * TclLookupVar, to avoid conflicts between trace flags and internal
     * namespace flags such as 'TCL_FIND_ONLY_NS'. This can now occur since we
     * have trace flags with values 0x1000 and higher.
     */

    flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
    varPtr = TclLookupVar(interp, part1, part2,
            (tracePtr->flags & flagMask) | TCL_LEAVE_ERR_MSG,
            "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
        return TCL_ERROR;
    }

    /*
     * Check for a nonsense flag combination. Note that this is a Tcl_Panic()
     * because there should be no code path that ever sets both flags.
     */

    if ((tracePtr->flags&TCL_TRACE_RESULT_DYNAMIC)
            && (tracePtr->flags&TCL_TRACE_RESULT_OBJECT)) {
        Tcl_Panic("bad result flag combination");
    }

    /*
     * Set up trace information.
     */

    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->flags = tracePtr->flags & flagMask;

    hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) varPtr, &isNew);
    if (isNew) {
        tracePtr->nextPtr = NULL;
    } else {
        tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr);
    }
    Tcl_SetHashValue(hPtr, (char *) tracePtr);

    /*
     * Mark the variable as traced so we know to call them.
     */

    varPtr->flags |= (tracePtr->flags & VAR_ALL_TRACES);

    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */