/*
 * 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.2.2.26 2007/09/07 03:15:16 dgp Exp $
 */

#include "tclInt.h"

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

 *----------------------------------------------------------------------
 */

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;
    TraceCommandInfo* tcmdPtr;
    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;

	}
    }
    iPtr->activeCmdTracePtr = active.nextPtr;
    if (state) {
	(void) Tcl_RestoreInterpState(interp, state);
    }




    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckInterpTraces --

 *----------------------------------------------------------------------
 */

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;

	if (traceCode == TCL_OK) {
	    (void) Tcl_RestoreInterpState(interp, state);
	} else {
	    Tcl_DiscardInterpState(state);
	}
    }




    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * CallTraceFunction --

    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.

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

    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

     * 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);

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

	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;
}

/*
 *----------------------------------------------------------------------

				 * 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_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;
}

/*
 *----------------------------------------------------------------------

 * 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

 * 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

    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;
    Tcl_HashEntry *hPtr;
    int new;

    /*
     * 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_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, &new);
    if (new) {
	tracePtr->nextPtr = NULL;
    } else {
	tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr);
    }
    Tcl_SetHashValue(hPtr, (char *) tracePtr);

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

    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */