/*
 * tclXdebug.c --
 *
 * Tcl command execution trace command.
 *-----------------------------------------------------------------------------
 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that the above copyright notice appear in all copies.  Karl Lehenbauer and
 * Mark Diekhans make no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without express or
 * implied warranty.
 *-----------------------------------------------------------------------------
 * $Id: tclXdebug.c,v 1.2 2002/04/03 02:50:35 hobbs Exp $
 *-----------------------------------------------------------------------------
 */

#include "tclExtdInt.h"

/*
 * Client data structure for the cmdtrace command.
 */
#define ARG_TRUNCATE_SIZE 40
#define CMD_TRUNCATE_SIZE 60

typedef struct traceInfo_t {
    Tcl_Interp       *interp;
    Tcl_Trace         traceId;
    int               inTrace;
    int               noEval;
    int               noTruncate;
    int               procCalls;
    int               depth;
    char             *callback;
    Tcl_Obj          *errorStatePtr;
    Tcl_AsyncHandler  errorAsyncHandler;
    Tcl_Channel       channel;
    } traceInfo_t, *traceInfo_pt;

/*
 * Prototypes of internal functions.
 */
static void
TraceDelete (Tcl_Interp   *interp,
             traceInfo_pt  infoPtr);

static void
PrintStr (Tcl_Channel  channel,
          const char *string,
          int          numChars,
          int          quoted);

static void
PrintArg (Tcl_Channel  channel,
          const char *argStr,
          int          noTruncate);

static void
TraceCode  (traceInfo_pt infoPtr,
            int          level,
            char        *command,
            int          argc,
            const char **argv);

static int
TraceCallbackErrorHandler (ClientData  clientData,
                           Tcl_Interp *interp,
                           int         code);

static void
TraceCallBack (Tcl_Interp   *interp,
               traceInfo_pt  infoPtr,
               int           level,
               char         *command,
               int           argc,
               const char **argv);

static void
CmdTraceRoutine (ClientData    clientData,
                 Tcl_Interp   *interp,
                 int           level,
                 char         *command,
                 Tcl_CmdProc  *cmdProc,
                 ClientData    cmdClientData,
                 int           argc,
                 const char **argv);

static int
TclX_CmdtraceObjCmd (ClientData clientData, 
                     Tcl_Interp *interp,
                     int objc,
                     Tcl_Obj *CONST objv[]);

static void
DebugCleanUp (ClientData  clientData,
              Tcl_Interp *interp);


/*-----------------------------------------------------------------------------
 * TraceDelete --
 *
 *   Delete the trace if active, reseting the structure.
 *-----------------------------------------------------------------------------
 */
static void
TraceDelete (Tcl_Interp *interp, traceInfo_pt infoPtr)
{
    if (infoPtr->traceId != NULL) {
        Tcl_DeleteTrace (interp, infoPtr->traceId);
        infoPtr->depth = 0;
        infoPtr->traceId = NULL;
        if (infoPtr->callback != NULL) {
            ckfree (infoPtr->callback);
            infoPtr->callback = NULL;
        }
    }
    if (infoPtr->errorAsyncHandler != NULL) {
        Tcl_AsyncDelete (infoPtr->errorAsyncHandler);
        infoPtr->errorAsyncHandler = NULL;
    }
}

/*-----------------------------------------------------------------------------
 * PrintStr --
 *
 *     Print an string, truncating it to the specified number of characters.
 * If the string contains newlines, \n is substituted.
 *-----------------------------------------------------------------------------
 */
static void
PrintStr (Tcl_Channel channel, const char *string, int numChars, int quoted)
{
    int idx;

    if (quoted) 
        Tcl_Write (channel, "{", 1);
    for (idx = 0; idx < numChars; idx++) {
        if (string [idx] == '\n') {
            Tcl_Write (channel, "\\n", 2);
        } else {
            Tcl_Write (channel, &(string [idx]), 1);
        }
    }
    if (numChars < (int) strlen (string))
        Tcl_Write (channel, "...", 3);
    if (quoted) 
        Tcl_Write (channel, "}", 1);
}

/*-----------------------------------------------------------------------------
 * PrintArg --
 *
 *   Print an argument string, truncating and adding "..." if its longer
 * then ARG_TRUNCATE_SIZE.  If the string contains white spaces, quote
 * it with braces.
 *-----------------------------------------------------------------------------
 */
static void
PrintArg (Tcl_Channel channel, const char *argStr, int noTruncate)
{
    int idx, argLen, printLen;
    int quoted;

    argLen = strlen (argStr);
    printLen = argLen;
    if ((!noTruncate) && (printLen > ARG_TRUNCATE_SIZE))
        printLen = ARG_TRUNCATE_SIZE;

    quoted = (printLen == 0);

    for (idx = 0; idx < printLen; idx++)
        if (ISSPACE (argStr [idx])) {
            quoted = TRUE;
            break;
        }

    PrintStr (channel, argStr, printLen, quoted);
}

/*-----------------------------------------------------------------------------
 * TraceCode --
 *
 *   Print out a trace of a code line.  Level is used for indenting
 * and marking lines and may be eval or procedure level.
 *-----------------------------------------------------------------------------
 */
static void
TraceCode (traceInfo_pt infoPtr,
           int level,
           char *command,
           int argc,
           const char **argv)
{
    int idx, printLen;
    char buf [32];

    sprintf (buf, "%2d:", level);
    Tcl_Write(infoPtr->channel, buf, -1); 

    if (level > 20)
        level = 20;
    for (idx = 0; idx < level; idx++) 
        Tcl_Write (infoPtr->channel, "  ", 2);

    if (infoPtr->noEval) {
        printLen = strlen (command);
        if ((!infoPtr->noTruncate) && (printLen > CMD_TRUNCATE_SIZE))
            printLen = CMD_TRUNCATE_SIZE;

        PrintStr (infoPtr->channel, (const char *) command, printLen, FALSE);
      } else {
          for (idx = 0; idx < argc; idx++) {
              if (idx > 0)
                  Tcl_Write (infoPtr->channel, " ", 1);
              PrintArg (infoPtr->channel,
                        argv [idx], 
                        infoPtr->noTruncate);
          }
    }

    TclX_WriteNL (infoPtr->channel);
    Tcl_Flush (infoPtr->channel);
}


/*-----------------------------------------------------------------------------
 * TraceCallbackErrorHandler --
 *
 *   Async handler that processes an callback error.  Generates either an
 * immediate or background error.
 *-----------------------------------------------------------------------------
 */
static int
TraceCallbackErrorHandler (ClientData clientData, Tcl_Interp *interp, int code)
{
    traceInfo_pt infoPtr = (traceInfo_pt) clientData;

    /*
     * Put back error message and state.  If not interp passed in, the error
     * is handled in the background.
     */
    TclX_RestoreResultErrorInfo (infoPtr->interp, infoPtr->errorStatePtr);
    infoPtr->errorStatePtr = NULL;
    if (interp == NULL) {
        Tcl_BackgroundError (infoPtr->interp);
    }    
    
    TraceDelete (interp, infoPtr);

    return TCL_ERROR;
}

/*-----------------------------------------------------------------------------
 * TraceCallBack --
 *
 *   Build and call a callback for the command that was just executed. The
 * following arguments are appended to the command:
 *   1) command - A string containing the text of the command, before any
 *      argument substitution.
 *   2) argv - A list of the final argument information that will be passed to
 *     the command after command, variable, and backslash substitution.
 *   3) evalLevel - The Tcl_Eval level.
 *   4) procLevel - The procedure level.
 * The code should allow for additional substitution of arguments in future
 * versions (such as a procedure with args as the last argument).  The value
 * of result, errorInfo and errorCode are preserved.  All other state must be
 * preserved by the procedure.  An error will result in an error being flagged
 * in the control block and async mark being called to handle the error
 * once the command has completed.
 *-----------------------------------------------------------------------------
 */
static void
TraceCallBack (Tcl_Interp *interp,
               traceInfo_pt infoPtr,
               int level,
               char *command,
               int argc,
               const char **argv)
{
    Interp       *iPtr = (Interp *) interp;
    Tcl_DString   callback;
    Tcl_Obj      *saveObjPtr;
    char         *cmdList;
    char          numBuf [32];

    Tcl_DStringInit (&callback);

    /*
     * Build the command to evaluate.
     */
    Tcl_DStringAppend (&callback, infoPtr->callback, -1);

    Tcl_DStringStartSublist (&callback);
    Tcl_DStringAppendElement (&callback, command);
    Tcl_DStringEndSublist (&callback);

    Tcl_DStringStartSublist (&callback);
    cmdList = Tcl_Merge (argc, argv);
    Tcl_DStringAppendElement (&callback, cmdList);
    ckfree (cmdList);
    Tcl_DStringEndSublist (&callback);

    sprintf (numBuf, "%d", level);
    Tcl_DStringAppendElement (&callback, numBuf);

    sprintf (numBuf, "%d",  ((iPtr->varFramePtr == NULL) ? 0 : 
             iPtr->varFramePtr->level));
    Tcl_DStringAppendElement (&callback, numBuf);

    saveObjPtr = TclX_SaveResultErrorInfo (interp);

    /*
     * Evaluate the command.  If an error occurs, set up the handler to be
     * called when its possible.
     */
    if (Tcl_Eval (interp, Tcl_DStringValue (&callback)) == TCL_ERROR) {
        Tcl_AddObjErrorInfo (interp, "\n    (\"cmdtrace\" callback command)",
                             -1);
        infoPtr->errorStatePtr = TclX_SaveResultErrorInfo (interp);
        Tcl_AsyncMark (infoPtr->errorAsyncHandler);
    }

    TclX_RestoreResultErrorInfo (interp, saveObjPtr);

    Tcl_DStringFree (&callback);
}

/*-----------------------------------------------------------------------------
 * CmdTraceRoutine --
 *
 *  Routine called by Tcl_Eval to trace a command.
 *-----------------------------------------------------------------------------
 */
static void
CmdTraceRoutine (ClientData clientData,
                 Tcl_Interp *interp,
                 int level,
                 char *command,
                 Tcl_CmdProc *cmdProc,
                 ClientData cmdClientData,
                 int argc,
                 const char **argv)
{
    Interp       *iPtr = (Interp *) interp;
    traceInfo_pt  infoPtr = (traceInfo_pt) clientData;
    int           procLevel;

    /*
     * If we are in an error.  
     */
    if (infoPtr->inTrace || (infoPtr->errorStatePtr != NULL)) {
        return;
    }
    infoPtr->inTrace = TRUE;

    if (infoPtr->procCalls) {
        if (TclFindProc (iPtr, argv [0]) != NULL) {
            if (infoPtr->callback != NULL) {
                TraceCallBack (interp, infoPtr, level, command, argc, argv);
            } else {
                procLevel = (iPtr->varFramePtr == NULL) ? 0 : 
                    iPtr->varFramePtr->level;
                TraceCode (infoPtr, procLevel, command, argc, argv);
            }
        }
    } else {
        if (infoPtr->callback != NULL) {
            TraceCallBack (interp, infoPtr, level, command, argc, argv);
        } else {
            TraceCode (infoPtr, level, command, argc, argv);
        }
    }
    infoPtr->inTrace = FALSE;
}

/*-----------------------------------------------------------------------------
 * Tcl_CmdtraceObjCmd --
 *
 * Implements the TCL trace command:
 *     cmdtrace level|on ?noeval? ?notruncate? ?procs? ?fileid? ?command cmd?
 *     cmdtrace off
 *     cmdtrace depth
 *-----------------------------------------------------------------------------
 */
static int
TclX_CmdtraceObjCmd (ClientData clientData,
                     Tcl_Interp *interp,
                     int objc,
                     Tcl_Obj *CONST objv[])
{
    traceInfo_pt  infoPtr = (traceInfo_pt) clientData;
    int idx;
    char *argStr, *callback;
    Tcl_Obj *channelId;

    if (objc < 2)
        goto argumentError;
    argStr = Tcl_GetStringFromObj (objv [1], NULL);

    /*
     * Handle `depth' sub-command.
     */
    if (STREQU (argStr, "depth")) {
        if (objc != 2)
            goto argumentError;
        Tcl_SetIntObj (Tcl_GetObjResult (interp),  infoPtr->depth);
        return TCL_OK;
    }

    /*
     * If a trace is in progress, delete it now.
     */
    TraceDelete (interp, infoPtr);

    /*
     * Handle off sub-command.
     */
    if (STREQU (argStr, "off")) {
        if (objc != 2)
            goto argumentError;
        return TCL_OK;
    }

    infoPtr->noEval     = FALSE;
    infoPtr->noTruncate = FALSE;
    infoPtr->procCalls  = FALSE;
    infoPtr->channel    = NULL;
    channelId           = NULL;
    callback            = NULL;

    if (STREQU (argStr, "on")) {
        infoPtr->depth = MAXINT;
    } else {
        if (Tcl_GetIntFromObj (interp, objv [1], &(infoPtr->depth)) != TCL_OK)
            return TCL_ERROR;
    }

    for (idx = 2; idx < objc; idx++) {
        argStr = Tcl_GetStringFromObj (objv [idx], NULL);
        if (STREQU (argStr, "notruncate")) {
            if (infoPtr->noTruncate)
                goto argumentError;
            infoPtr->noTruncate = TRUE;
            continue;
        }
        if (STREQU (argStr, "noeval")) {
            if (infoPtr->noEval)
                goto argumentError;
            infoPtr->noEval = TRUE;
            continue;
        }
        if (STREQU (argStr, "procs")) {
            if (infoPtr->procCalls)
                goto argumentError;
            infoPtr->procCalls = TRUE;
            continue;
        }
        if (STRNEQU (argStr, "std", 3) || 
                STRNEQU (argStr, "file", 4)) {
            if (channelId != NULL)
                goto argumentError;
            if (callback != NULL)
                goto mixCommandAndFile;
            channelId = objv [idx];
            continue;
        }
        if (STREQU (argStr, "command")) {
            if (callback != NULL)
                goto argumentError;
            if (channelId != NULL)
                goto mixCommandAndFile;
            if (idx == objc - 1)
                goto missingCommand;
            callback = Tcl_GetStringFromObj (objv [++idx], NULL);
            continue;
        }
        goto invalidOption;
    }

    if (callback != NULL) {
        infoPtr->callback = ckstrdup (callback);
        infoPtr->errorAsyncHandler =
            Tcl_AsyncCreate (TraceCallbackErrorHandler, 
                             (ClientData) infoPtr);

    } else {
        if (channelId == NULL) {
            infoPtr->channel = TclX_GetOpenChannel (interp,
                                                    "stdout",
                                                    TCL_WRITABLE);
        } else {
            infoPtr->channel = TclX_GetOpenChannelObj (interp,
                                                       channelId,
                                                       TCL_WRITABLE);
        }
        if (infoPtr->channel == NULL)
            return TCL_ERROR;
    }
    infoPtr->traceId =
        Tcl_CreateTrace (interp,
                         infoPtr->depth,
                         (Tcl_CmdTraceProc*) CmdTraceRoutine,
                         (ClientData) infoPtr);
    return TCL_OK;

  argumentError:
    TclX_AppendObjResult (interp, tclXWrongArgs, objv [0], 
                          " level | on ?noeval? ?notruncate? ?procs?",
                          "?fileid? ?command cmd? | off | depth",
                          (char *) NULL);
    return TCL_ERROR;

  missingCommand:
    TclX_AppendObjResult (interp, "command option requires an argument",
                          (char *) NULL);
    return TCL_ERROR;

  mixCommandAndFile:
    TclX_AppendObjResult (interp, "can not specify both the command option ",
                          "and a file handle", (char *) NULL);
    return TCL_ERROR;

  invalidOption:
    TclX_AppendObjResult (interp, "invalid option: expected ",
                          "one of \"noeval\", \"notruncate\", \"procs\", ",
                          "\"command\", or a file id", (char *) NULL);
    return TCL_ERROR;
}

/*-----------------------------------------------------------------------------
 * DebugCleanUp --
 *
 *  Release the debug data area when the interpreter is deleted.
 *-----------------------------------------------------------------------------
 */
static void
DebugCleanUp (ClientData clientData, Tcl_Interp *interp)
{
    traceInfo_pt infoPtr = (traceInfo_pt) clientData;

    TraceDelete (interp, infoPtr);
    ckfree ((char *) infoPtr);
}

/*-----------------------------------------------------------------------------
 * TclX_DebugInit --
 *
 *  Initialize the TCL debugging commands.
 *-----------------------------------------------------------------------------
 */
void
TclX_DebugInit (Tcl_Interp *interp)
{
    traceInfo_pt infoPtr;

    infoPtr = (traceInfo_pt) ckalloc (sizeof (traceInfo_t));

    infoPtr->interp = interp;
    infoPtr->traceId = NULL;
    infoPtr->inTrace = FALSE;
    infoPtr->noEval = FALSE;
    infoPtr->noTruncate = FALSE;
    infoPtr->procCalls = FALSE;
    infoPtr->depth = 0;
    infoPtr->callback = NULL;
    infoPtr->errorStatePtr = NULL;
    infoPtr->errorAsyncHandler = NULL;
    infoPtr->channel = NULL;

    Tcl_CallWhenDeleted (interp, DebugCleanUp, (ClientData) infoPtr);

    Tcl_CreateObjCommand (interp, "cmdtrace",
                          TclX_CmdtraceObjCmd, 
                          (ClientData) infoPtr,
                          (Tcl_CmdDeleteProc*) NULL);
}

/* vim: set ts=4 sw=4 sts=4 et : */