/* 
 * trace.c --
 *
 * Copyright (c) 1999 Vince Darley
 *
 * This file is distributed under the same license as Tcl.
 * 
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * 
 * Note: It would be relatively easy to take this code and use it
 * to extend Tcl's current 'trace' command to perform both variable
 * and command tracing.  It would make a nice addition to the Tcl core.
 * 
 * Notice that I didn't think it sensible to implement the idea of
 * calling a Tcl proc with each traced command (as is done with
 * variable traces).  This seemed likely to (i) lead to nasty
 * recursions which would have to be worked around, and (ii) be
 * unnecessary, since the primary use of this code would seem to be
 * debugging -- 'my proc foo doesn't do what I think it should, give me
 * a dump of everything that's happening inside it'.
 * 
 * Basic use is:
 * 
 *    # register trace
 *    tracecommand on foo
 *    # now call some code which uses 'foo'
 *    foo arg1 arg2 arg3
 *    # now see what happened inside foo
 *    tracecommand dump foo
 *    # now get rid of the trace and free associated memory
 *    tracecommand off foo
 *
 */

#define TCL_USE_STUBS
#include <tcl.h>

/* For Tcl_GetCommandFromObj, Tcl_GetCommandFullName */
#include <tclInt.h>
#include <string.h>

extern Tcl_ObjCmdProc Trace_ObjCmd;
DLLEXPORT int Trace_Init(Tcl_Interp* interp);

static Tcl_CmdTraceObjProc traceCmd;
static Tcl_InterpDeleteProc traceCleanup;
static void addIndentTruncate(Tcl_DString *ds, int indent, int truncate, Tcl_DString *add);

typedef struct traceInfo {
    Tcl_DString traceDetails;
    Tcl_Trace tracePtr;
    Tcl_Command cmdPtr;
    int truncationLength;
    int relativeDepth;
    struct traceInfo* nextPtr;
} traceInfo;

typedef struct interpTraceInfo {
    traceInfo* traces;
} interpTraceInfo;

int Trace_Init(Tcl_Interp* interp) {
    interpTraceInfo* traceInfoPtr;
    Tcl_InitStubs(interp,TCL_VERSION,0);
    
    traceInfoPtr = (interpTraceInfo*) ckalloc(sizeof(interpTraceInfo));
    traceInfoPtr->traces = NULL;
    
    Tcl_CallWhenDeleted(interp, traceCleanup, (ClientData) traceInfoPtr);
    Tcl_CreateObjCommand(interp, "tracecommand", Trace_ObjCmd, 
			 (ClientData)traceInfoPtr, (Tcl_CmdDeleteProc*) NULL);
    return TCL_OK;
}

int Trace_ObjCmd(clientData, interp, objc, objv)
    ClientData clientData;		/* Trace info */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int index;
    int flags, min, max, truncate, relativeDepth, c;
    traceInfo *loopPtr, *prevPtr;
    interpTraceInfo *traceInfoPtr = (interpTraceInfo*)clientData;
    Tcl_Command cmdPtr;
    
    static char *optionStrings[] = {
	"dump", "list", "off", "on", NULL
    };
    enum options {
	TRACE_DUMP, TRACE_LIST, TRACE_OFF, TRACE_ON
    };
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if ((enum options) index == TRACE_LIST) {
	Tcl_Obj *resObj = Tcl_NewListObj(0,NULL);
	for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
	    Tcl_Obj *objPtr = Tcl_NewObj();
	    Tcl_GetCommandFullName(interp, loopPtr->cmdPtr, objPtr);
	    Tcl_ListObjAppendElement(interp,resObj,objPtr);
	}
	Tcl_SetObjResult(interp,resObj);
	return TCL_OK;
    } 
    
    if(objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv, "command");
	return TCL_ERROR;
    }
    cmdPtr =  Tcl_GetCommandFromObj(interp, objv[2]);
    if(cmdPtr == NULL) {
	Tcl_AppendResult(interp, "Bad argument \"", Tcl_GetString(objv[2]),
	    "\": must be the name of an existing command or procedure",
	    (char *) NULL);
	return TCL_ERROR;
    }
    
    switch ((enum options) index) {
      case TRACE_DUMP:
	for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
	    if(loopPtr->cmdPtr == cmdPtr) {
		Tcl_DStringResult(interp,&loopPtr->traceDetails);
		return TCL_OK;
	    }
	}
	Tcl_AppendResult(interp, "There is no existing trace on \"", Tcl_GetString(objv[2]),
	       "\"", (char *) NULL);
	return TCL_ERROR;
	break;
      case TRACE_ON: 
	flags = min = max = truncate = relativeDepth = 0;
	c = 3;
	while(c < objc) {
	    int len;
	    char* str = Tcl_GetStringFromObj(objv[c],&len);
	    if(str[0] == '-' && c != objc-1) {
		if (len == 9 && !strncmp(str,"-minlevel",9)) {
		    if (Tcl_GetIntFromObj(interp,objv[c+1],&min) == TCL_ERROR) {
		        return TCL_ERROR;
		    }
		    c++;
		} else if (len == 9 && !strncmp(str,"-maxlevel",9)) {
		    if (Tcl_GetIntFromObj(interp,objv[c+1],&max) == TCL_ERROR) {
			return TCL_ERROR;
		    }
		    c++;
		} else if (len == 9 && !strncmp(str,"-truncate",9)) {
		    if (Tcl_GetIntFromObj(interp,objv[c+1],&truncate) == TCL_ERROR) {
			return TCL_ERROR;
		    }
		    c++;
		} else if (len == 6 && !strncmp(str,"-depth",6)) {
		    if (Tcl_GetIntFromObj(interp,objv[c+1],&relativeDepth) == TCL_ERROR) {
			return TCL_ERROR;
		    }
		    c++;
		} else {
		    goto bad_args;
		}
	    } else if (len == 6 && !strncmp(str,"before",6)) {
		flags |= TCL_CMD_TRACE_BEFORE;
	    } else if (len == 5 && !strncmp(str,"after",5)) {
		flags |= TCL_CMD_TRACE_AFTER;
	    } else {
		bad_args:
		Tcl_AppendResult(interp, "Bad argument \"", Tcl_GetString(objv[c]),
		   "\": should be before, after -minlevel n, -maxlevel n, -depth n or -truncate n", 
		   (char *) NULL);
		return TCL_ERROR;
	    }
	    c++;
	}
	loopPtr = (traceInfo*) ckalloc(sizeof(traceInfo));
	loopPtr->cmdPtr = cmdPtr;
	Tcl_DStringInit(&loopPtr->traceDetails);
	loopPtr->tracePtr = Tcl_CreateTraceObj(interp,objv[2],flags,max,min,traceCmd,(ClientData)loopPtr);
	loopPtr->truncationLength = truncate;
	loopPtr->relativeDepth = relativeDepth;
	loopPtr->nextPtr = traceInfoPtr->traces;
	traceInfoPtr->traces = loopPtr;
	break;
      case TRACE_OFF:
	prevPtr = NULL;
	for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
	    if(loopPtr->cmdPtr == cmdPtr) {
		Tcl_DeleteTrace(interp,loopPtr->tracePtr);
		Tcl_DStringFree(&loopPtr->traceDetails);
		if(prevPtr != NULL) {
		    prevPtr->nextPtr = loopPtr->nextPtr;
		} else {
		    traceInfoPtr->traces = NULL;
		}
		ckfree((char*)loopPtr);
		return TCL_OK;
	    }
	    prevPtr = loopPtr;
	}
	Tcl_AppendResult(interp, "There is no existing trace on \"", Tcl_GetString(objv[2]),
	       "\"", (char *) NULL);
	return TCL_ERROR;
	break;
    }
    return TCL_OK;
}

void traceCleanup(ClientData clientData, Tcl_Interp *interp) {
    traceInfo *loopPtr, *prevPtr;
    interpTraceInfo *traceInfoPtr = (interpTraceInfo*)clientData;
    for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) {
	Tcl_DStringFree(&loopPtr->traceDetails);
	Tcl_DeleteTrace(interp,loopPtr->tracePtr);
	prevPtr= loopPtr;
	loopPtr = loopPtr->nextPtr;
	ckfree((char*)prevPtr);
    }
    ckfree((char*)traceInfoPtr);
}

void traceCmd(ClientData clientData, Tcl_Interp *interp, 
	      int level, int startLevel, int flags, int code,
	      char* command, int length, Tcl_Command cmdInfo,
	      int objc, struct Tcl_Obj *CONST objv[]) {
    Tcl_DString ds;
    traceInfo* traceInfoPtr = (traceInfo*)clientData;
    /* Cut-off anything deeper than this */
    if (traceInfoPtr->relativeDepth > 0 && (level-startLevel > traceInfoPtr->relativeDepth)) {
        return;
    }
    if (flags & TCL_CMD_TRACE_BEFORE) {
	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, "'", 1);
	Tcl_DStringAppend(&ds, command, length);
	Tcl_DStringAppend(&ds, "'", 1);
	Tcl_DStringAppend(&ds, "\n", 1);
	addIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds);
	Tcl_DStringFree(&ds);
    }
    if (flags & TCL_CMD_TRACE_AFTER) {
	int i;
	Tcl_DStringInit(&ds);
	for (i = 0; i < objc; i++) {
	    char* str;
	    int len;
	    str = Tcl_GetStringFromObj(objv[i],&len);
	    Tcl_DStringAppend(&ds, str, len);
	    Tcl_DStringAppend(&ds, " ", 1);
	}
	Tcl_DStringAppend(&ds, "\n", 1);
	addIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds);
	Tcl_DStringFree(&ds);
    }
    if (flags & TCL_CMD_TRACE_AFTER) {
	Tcl_DStringInit(&ds);
	Tcl_DStringAppend(&ds, code == TCL_ERROR ? "ERROR: " : "OK: ", -1);
	Tcl_DStringAppend(&ds, Tcl_GetStringResult(interp), -1);
	Tcl_DStringAppend(&ds, "\n", 1);
	addIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds);
	Tcl_DStringFree(&ds);
    }
}

void addIndentTruncate(Tcl_DString *ds, int indent, int truncate, Tcl_DString *add) {
    int i;
    for (i = 1; i < indent; i++) {
	Tcl_DStringAppend(ds, " ", 1);
    }
    if(truncate > 0 && (truncate - indent < Tcl_DStringLength(add))) {
	Tcl_DStringAppend(ds, Tcl_DStringValue(add), truncate - indent);
	Tcl_DStringAppend(ds,"...\n",4);
    } else {
	Tcl_DStringAppend(ds, Tcl_DStringValue(add), Tcl_DStringLength(add));
    }
}