1/*
2 * tclXdebug.c --
3 *
4 * Tcl command execution trace command.
5 *-----------------------------------------------------------------------------
6 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans.
7 *
8 * Permission to use, copy, modify, and distribute this software and its
9 * documentation for any purpose and without fee is hereby granted, provided
10 * that the above copyright notice appear in all copies.  Karl Lehenbauer and
11 * Mark Diekhans make no representations about the suitability of this
12 * software for any purpose.  It is provided "as is" without express or
13 * implied warranty.
14 *-----------------------------------------------------------------------------
15 * $Id: tclXdebug.c,v 1.3 2002/09/26 00:19:18 hobbs Exp $
16 *-----------------------------------------------------------------------------
17 */
18
19#include "tclExtdInt.h"
20
21/*
22 * Client data structure for the cmdtrace command.
23 */
24#define ARG_TRUNCATE_SIZE 40
25#define CMD_TRUNCATE_SIZE 60
26
27typedef struct traceInfo_t {
28    Tcl_Interp       *interp;
29    Tcl_Trace         traceId;
30    int               inTrace;
31    int               noEval;
32    int               noTruncate;
33    int               procCalls;
34    int               depth;
35    char             *callback;
36    Tcl_Obj          *errorStatePtr;
37    Tcl_AsyncHandler  errorAsyncHandler;
38    Tcl_Channel       channel;
39    } traceInfo_t, *traceInfo_pt;
40
41/*
42 * Prototypes of internal functions.
43 */
44static void
45TraceDelete _ANSI_ARGS_((Tcl_Interp   *interp,
46                         traceInfo_pt  infoPtr));
47
48static void
49PrintStr _ANSI_ARGS_((Tcl_Channel  channel,
50                      CONST84 char *string,
51                      int          numChars,
52                      int          quoted));
53
54static void
55PrintArg _ANSI_ARGS_((Tcl_Channel  channel,
56                      CONST84 char *argStr,
57                      int          noTruncate));
58
59static void
60TraceCode  _ANSI_ARGS_((traceInfo_pt infoPtr,
61                        int          level,
62                        char        *command,
63                        int          argc,
64                        CONST84 char **argv));
65
66static int
67TraceCallbackErrorHandler _ANSI_ARGS_((ClientData  clientData,
68                                       Tcl_Interp *interp,
69                                       int         code));
70
71static void
72TraceCallBack _ANSI_ARGS_((Tcl_Interp   *interp,
73                           traceInfo_pt  infoPtr,
74                           int           level,
75                           char         *command,
76                           int           argc,
77                           CONST84 char **argv));
78
79static void
80CmdTraceRoutine _ANSI_ARGS_((ClientData    clientData,
81                             Tcl_Interp   *interp,
82                             int           level,
83                             char         *command,
84                             Tcl_CmdProc  *cmdProc,
85                             ClientData    cmdClientData,
86                             int           argc,
87                             CONST84 char **argv));
88
89static int
90TclX_CmdtraceObjCmd _ANSI_ARGS_((ClientData clientData,
91                                 Tcl_Interp *interp,
92                                 int objc,
93                                 Tcl_Obj *CONST objv[]));
94
95static void
96DebugCleanUp _ANSI_ARGS_((ClientData  clientData,
97                          Tcl_Interp *interp));
98
99
100/*-----------------------------------------------------------------------------
101 * TraceDelete --
102 *
103 *   Delete the trace if active, reseting the structure.
104 *-----------------------------------------------------------------------------
105 */
106static void
107TraceDelete (interp, infoPtr)
108    Tcl_Interp   *interp;
109    traceInfo_pt  infoPtr;
110{
111    if (infoPtr->traceId != NULL) {
112        Tcl_DeleteTrace (interp, infoPtr->traceId);
113        infoPtr->depth = 0;
114        infoPtr->traceId = NULL;
115        if (infoPtr->callback != NULL) {
116            ckfree (infoPtr->callback);
117            infoPtr->callback = NULL;
118        }
119    }
120    if (infoPtr->errorAsyncHandler != NULL) {
121        Tcl_AsyncDelete (infoPtr->errorAsyncHandler);
122        infoPtr->errorAsyncHandler = NULL;
123    }
124}
125
126/*-----------------------------------------------------------------------------
127 * PrintStr --
128 *
129 *     Print an string, truncating it to the specified number of characters.
130 * If the string contains newlines, \n is substituted.
131 *-----------------------------------------------------------------------------
132 */
133static void
134PrintStr (channel, string, numChars, quoted)
135    Tcl_Channel  channel;
136    CONST84 char *string;
137    int          numChars;
138    int          quoted;
139{
140    int idx;
141
142    if (quoted)
143        Tcl_Write (channel, "{", 1);
144    for (idx = 0; idx < numChars; idx++) {
145        if (string [idx] == '\n') {
146            Tcl_Write (channel, "\\n", 2);
147        } else {
148            Tcl_Write (channel, &(string [idx]), 1);
149        }
150    }
151    if (numChars < (int) strlen (string))
152        Tcl_Write (channel, "...", 3);
153    if (quoted)
154        Tcl_Write (channel, "}", 1);
155}
156
157/*-----------------------------------------------------------------------------
158 * PrintArg --
159 *
160 *   Print an argument string, truncating and adding "..." if its longer
161 * then ARG_TRUNCATE_SIZE.  If the string contains white spaces, quote
162 * it with braces.
163 *-----------------------------------------------------------------------------
164 */
165static void
166PrintArg (channel, argStr, noTruncate)
167    Tcl_Channel  channel;
168    CONST84 char *argStr;
169    int          noTruncate;
170{
171    int idx, argLen, printLen;
172    int quoted;
173
174    argLen = strlen (argStr);
175    printLen = argLen;
176    if ((!noTruncate) && (printLen > ARG_TRUNCATE_SIZE))
177        printLen = ARG_TRUNCATE_SIZE;
178
179    quoted = (printLen == 0);
180
181    for (idx = 0; idx < printLen; idx++)
182        if (ISSPACE (argStr [idx])) {
183            quoted = TRUE;
184            break;
185        }
186
187    PrintStr (channel, argStr, printLen, quoted);
188}
189
190/*-----------------------------------------------------------------------------
191 * TraceCode --
192 *
193 *   Print out a trace of a code line.  Level is used for indenting
194 * and marking lines and may be eval or procedure level.
195 *-----------------------------------------------------------------------------
196 */
197static void
198TraceCode (infoPtr, level, command, argc, argv)
199    traceInfo_pt infoPtr;
200    int          level;
201    char        *command;
202    int          argc;
203    CONST84 char **argv;
204{
205    int idx, cmdLen, printLen;
206    char buf [32];
207
208    sprintf (buf, "%2d:", level);
209    Tcl_Write(infoPtr->channel, buf, -1);
210
211    if (level > 20)
212        level = 20;
213    for (idx = 0; idx < level; idx++)
214        Tcl_Write (infoPtr->channel, "  ", 2);
215
216    if (infoPtr->noEval) {
217        cmdLen = printLen = strlen (command);
218        if ((!infoPtr->noTruncate) && (printLen > CMD_TRUNCATE_SIZE))
219            printLen = CMD_TRUNCATE_SIZE;
220
221        PrintStr (infoPtr->channel, (CONST84 char *) command, printLen, FALSE);
222      } else {
223          for (idx = 0; idx < argc; idx++) {
224              if (idx > 0)
225                  Tcl_Write (infoPtr->channel, " ", 1);
226              PrintArg (infoPtr->channel,
227                        argv [idx],
228                        infoPtr->noTruncate);
229          }
230    }
231
232    TclX_WriteNL (infoPtr->channel);
233    Tcl_Flush (infoPtr->channel);
234}
235
236
237/*-----------------------------------------------------------------------------
238 * TraceCallbackErrorHandler --
239 *
240 *   Async handler that processes an callback error.  Generates either an
241 * immediate or background error.
242 *-----------------------------------------------------------------------------
243 */
244static int
245TraceCallbackErrorHandler (clientData, interp, code)
246    ClientData  clientData;
247    Tcl_Interp *interp;
248    int         code;
249{
250    traceInfo_pt infoPtr = (traceInfo_pt) clientData;
251
252    /*
253     * Put back error message and state.  If not interp passed in, the error
254     * is handled in the background.
255     */
256    TclX_RestoreResultErrorInfo (infoPtr->interp, infoPtr->errorStatePtr);
257    infoPtr->errorStatePtr = NULL;
258    if (interp == NULL) {
259        Tcl_BackgroundError (infoPtr->interp);
260    }
261
262    TraceDelete (interp, infoPtr);
263
264    return TCL_ERROR;
265}
266
267/*-----------------------------------------------------------------------------
268 * TraceCallBack --
269 *
270 *   Build and call a callback for the command that was just executed. The
271 * following arguments are appended to the command:
272 *   1) command - A string containing the text of the command, before any
273 *      argument substitution.
274 *   2) argv - A list of the final argument information that will be passed to
275 *     the command after command, variable, and backslash substitution.
276 *   3) evalLevel - The Tcl_Eval level.
277 *   4) procLevel - The procedure level.
278 * The code should allow for additional substitution of arguments in future
279 * versions (such as a procedure with args as the last argument).  The value
280 * of result, errorInfo and errorCode are preserved.  All other state must be
281 * preserved by the procedure.  An error will result in an error being flagged
282 * in the control block and async mark being called to handle the error
283 * once the command has completed.
284 *-----------------------------------------------------------------------------
285 */
286static void
287TraceCallBack (interp, infoPtr, level, command, argc, argv)
288    Tcl_Interp   *interp;
289    traceInfo_pt  infoPtr;
290    int           level;
291    char         *command;
292    int           argc;
293    CONST84 char **argv;
294{
295    Interp       *iPtr = (Interp *) interp;
296    Tcl_DString   callback;
297    Tcl_Obj      *saveObjPtr;
298    char         *cmdList;
299    char          numBuf [32];
300
301    Tcl_DStringInit (&callback);
302
303    /*
304     * Build the command to evaluate.
305     */
306    Tcl_DStringAppend (&callback, infoPtr->callback, -1);
307
308    Tcl_DStringStartSublist (&callback);
309    Tcl_DStringAppendElement (&callback, command);
310    Tcl_DStringEndSublist (&callback);
311
312    Tcl_DStringStartSublist (&callback);
313    cmdList = Tcl_Merge (argc, argv);
314    Tcl_DStringAppendElement (&callback, cmdList);
315    ckfree (cmdList);
316    Tcl_DStringEndSublist (&callback);
317
318    sprintf (numBuf, "%d", level);
319    Tcl_DStringAppendElement (&callback, numBuf);
320
321    sprintf (numBuf, "%d",  ((iPtr->varFramePtr == NULL) ? 0 :
322             iPtr->varFramePtr->level));
323    Tcl_DStringAppendElement (&callback, numBuf);
324
325    saveObjPtr = TclX_SaveResultErrorInfo (interp);
326
327    /*
328     * Evaluate the command.  If an error occurs, set up the handler to be
329     * called when its possible.
330     */
331    if (Tcl_Eval (interp, Tcl_DStringValue (&callback)) == TCL_ERROR) {
332        Tcl_AddObjErrorInfo (interp, "\n    (\"cmdtrace\" callback command)",
333                             -1);
334        infoPtr->errorStatePtr = TclX_SaveResultErrorInfo (interp);
335        Tcl_AsyncMark (infoPtr->errorAsyncHandler);
336    }
337
338    TclX_RestoreResultErrorInfo (interp, saveObjPtr);
339
340    Tcl_DStringFree (&callback);
341}
342
343/*-----------------------------------------------------------------------------
344 * CmdTraceRoutine --
345 *
346 *  Routine called by Tcl_Eval to trace a command.
347 *-----------------------------------------------------------------------------
348 */
349static void
350CmdTraceRoutine (clientData, interp, level, command, cmdProc, cmdClientData,
351                 argc, argv)
352    ClientData    clientData;
353    Tcl_Interp   *interp;
354    int           level;
355    char         *command;
356    Tcl_CmdProc  *cmdProc;
357    ClientData    cmdClientData;
358    int           argc;
359    CONST84 char **argv;
360{
361    Interp       *iPtr = (Interp *) interp;
362    traceInfo_pt  infoPtr = (traceInfo_pt) clientData;
363    int           procLevel;
364
365    /*
366     * If we are in an error.
367     */
368    if (infoPtr->inTrace || (infoPtr->errorStatePtr != NULL)) {
369        return;
370    }
371    infoPtr->inTrace = TRUE;
372
373    if (infoPtr->procCalls) {
374        if (TclFindProc (iPtr, argv [0]) != NULL) {
375            if (infoPtr->callback != NULL) {
376                TraceCallBack (interp, infoPtr, level, command, argc, argv);
377            } else {
378                procLevel = (iPtr->varFramePtr == NULL) ? 0 :
379                    iPtr->varFramePtr->level;
380                TraceCode (infoPtr, procLevel, command, argc, argv);
381            }
382        }
383    } else {
384        if (infoPtr->callback != NULL) {
385            TraceCallBack (interp, infoPtr, level, command, argc, argv);
386        } else {
387            TraceCode (infoPtr, level, command, argc, argv);
388        }
389    }
390    infoPtr->inTrace = FALSE;
391}
392
393/*-----------------------------------------------------------------------------
394 * Tcl_CmdtraceObjCmd --
395 *
396 * Implements the TCL trace command:
397 *     cmdtrace level|on ?noeval? ?notruncate? ?procs? ?fileid? ?command cmd?
398 *     cmdtrace off
399 *     cmdtrace depth
400 *-----------------------------------------------------------------------------
401 */
402static int
403TclX_CmdtraceObjCmd (clientData, interp, objc, objv)
404    ClientData  clientData;
405    Tcl_Interp *interp;
406    int         objc;
407    Tcl_Obj    *CONST objv[];
408{
409    traceInfo_pt  infoPtr = (traceInfo_pt) clientData;
410    int idx;
411    char *argStr, *callback;
412    Tcl_Obj *channelId;
413
414    if (objc < 2)
415        goto argumentError;
416    argStr = Tcl_GetStringFromObj (objv [1], NULL);
417
418    /*
419     * Handle `depth' sub-command.
420     */
421    if (STREQU (argStr, "depth")) {
422        if (objc != 2)
423            goto argumentError;
424        Tcl_SetIntObj (Tcl_GetObjResult (interp),  infoPtr->depth);
425        return TCL_OK;
426    }
427
428    /*
429     * If a trace is in progress, delete it now.
430     */
431    TraceDelete (interp, infoPtr);
432
433    /*
434     * Handle off sub-command.
435     */
436    if (STREQU (argStr, "off")) {
437        if (objc != 2)
438            goto argumentError;
439        return TCL_OK;
440    }
441
442    infoPtr->noEval     = FALSE;
443    infoPtr->noTruncate = FALSE;
444    infoPtr->procCalls  = FALSE;
445    infoPtr->channel    = NULL;
446    channelId           = NULL;
447    callback            = NULL;
448
449    if (STREQU (argStr, "on")) {
450        infoPtr->depth = MAXINT;
451    } else {
452        if (Tcl_GetIntFromObj (interp, objv [1], &(infoPtr->depth)) != TCL_OK)
453            return TCL_ERROR;
454    }
455
456    for (idx = 2; idx < objc; idx++) {
457        argStr = Tcl_GetStringFromObj (objv [idx], NULL);
458        if (STREQU (argStr, "notruncate")) {
459            if (infoPtr->noTruncate)
460                goto argumentError;
461            infoPtr->noTruncate = TRUE;
462            continue;
463        }
464        if (STREQU (argStr, "noeval")) {
465            if (infoPtr->noEval)
466                goto argumentError;
467            infoPtr->noEval = TRUE;
468            continue;
469        }
470        if (STREQU (argStr, "procs")) {
471            if (infoPtr->procCalls)
472                goto argumentError;
473            infoPtr->procCalls = TRUE;
474            continue;
475        }
476        if (STRNEQU (argStr, "std", 3) ||
477                STRNEQU (argStr, "file", 4)) {
478            if (channelId != NULL)
479                goto argumentError;
480            if (callback != NULL)
481                goto mixCommandAndFile;
482            channelId = objv [idx];
483            continue;
484        }
485        if (STREQU (argStr, "command")) {
486            if (callback != NULL)
487                goto argumentError;
488            if (channelId != NULL)
489                goto mixCommandAndFile;
490            if (idx == objc - 1)
491                goto missingCommand;
492            callback = Tcl_GetStringFromObj (objv [++idx], NULL);
493            continue;
494        }
495        goto invalidOption;
496    }
497
498    if (callback != NULL) {
499        infoPtr->callback = ckstrdup (callback);
500        infoPtr->errorAsyncHandler =
501            Tcl_AsyncCreate (TraceCallbackErrorHandler,
502                             (ClientData) infoPtr);
503
504    } else {
505        if (channelId == NULL) {
506            infoPtr->channel = TclX_GetOpenChannel (interp,
507                                                    "stdout",
508                                                    TCL_WRITABLE);
509        } else {
510            infoPtr->channel = TclX_GetOpenChannelObj (interp,
511                                                       channelId,
512                                                       TCL_WRITABLE);
513        }
514        if (infoPtr->channel == NULL)
515            return TCL_ERROR;
516    }
517    infoPtr->traceId =
518        Tcl_CreateTrace (interp,
519                         infoPtr->depth,
520                         (Tcl_CmdTraceProc*) CmdTraceRoutine,
521                         (ClientData) infoPtr);
522    return TCL_OK;
523
524  argumentError:
525    TclX_AppendObjResult (interp, tclXWrongArgs, objv [0],
526                          " level | on ?noeval? ?notruncate? ?procs?",
527                          "?fileid? ?command cmd? | off | depth",
528                          (char *) NULL);
529    return TCL_ERROR;
530
531  missingCommand:
532    TclX_AppendObjResult (interp, "command option requires an argument",
533                          (char *) NULL);
534    return TCL_ERROR;
535
536  mixCommandAndFile:
537    TclX_AppendObjResult (interp, "can not specify both the command option ",
538                          "and a file handle", (char *) NULL);
539    return TCL_ERROR;
540
541  invalidOption:
542    TclX_AppendObjResult (interp, "invalid option: expected ",
543                          "one of \"noeval\", \"notruncate\", \"procs\", ",
544                          "\"command\", or a file id", (char *) NULL);
545    return TCL_ERROR;
546}
547
548/*-----------------------------------------------------------------------------
549 * DebugCleanUp --
550 *
551 *  Release the debug data area when the interpreter is deleted.
552 *-----------------------------------------------------------------------------
553 */
554static void
555DebugCleanUp (clientData, interp)
556    ClientData  clientData;
557    Tcl_Interp *interp;
558{
559    traceInfo_pt infoPtr = (traceInfo_pt) clientData;
560
561    TraceDelete (interp, infoPtr);
562    ckfree ((char *) infoPtr);
563}
564
565/*-----------------------------------------------------------------------------
566 * TclX_DebugInit --
567 *
568 *  Initialize the TCL debugging commands.
569 *-----------------------------------------------------------------------------
570 */
571void
572TclX_DebugInit (interp)
573    Tcl_Interp *interp;
574{
575    traceInfo_pt infoPtr;
576
577    infoPtr = (traceInfo_pt) ckalloc (sizeof (traceInfo_t));
578
579    infoPtr->interp = interp;
580    infoPtr->traceId = NULL;
581    infoPtr->inTrace = FALSE;
582    infoPtr->noEval = FALSE;
583    infoPtr->noTruncate = FALSE;
584    infoPtr->procCalls = FALSE;
585    infoPtr->depth = 0;
586    infoPtr->callback = NULL;
587    infoPtr->errorStatePtr = NULL;
588    infoPtr->errorAsyncHandler = NULL;
589    infoPtr->channel = NULL;
590
591    Tcl_CallWhenDeleted (interp, DebugCleanUp, (ClientData) infoPtr);
592
593    Tcl_CreateObjCommand (interp, "cmdtrace",
594                          TclX_CmdtraceObjCmd,
595                          (ClientData) infoPtr,
596                          (Tcl_CmdDeleteProc*) NULL);
597}
598
599
600
601
602