4 * Tcl command execution trace command.
5 *-----------------------------------------------------------------------------
6 * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
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
14 *-----------------------------------------------------------------------------
15 * $Id: tclXdebug.c,v 2.0 1992/10/16 04:50:34 markd Rel $
16 *-----------------------------------------------------------------------------
22 * Client data structure for the cmdtrace command.
24 #define ARG_TRUNCATE_SIZE 40
25 #define CMD_TRUNCATE_SIZE 60
27 typedef struct traceInfo_t
{
29 Tcl_Trace traceHolder
;
35 FILE *filePtr
; /* File to output trace to. */
36 } traceInfo_t
, *traceInfo_pt
;
39 * Prototypes of internal functions.
42 PrintStr
_ANSI_ARGS_((FILE *filePtr
,
47 PrintArg
_ANSI_ARGS_((FILE *filePtr
,
52 TraceCode
_ANSI_ARGS_((traceInfo_pt traceInfoPtr
,
59 CmdTraceRoutine
_ANSI_ARGS_((ClientData clientData
,
64 ClientData cmdClientData
,
69 CleanUpDebug
_ANSI_ARGS_((ClientData clientData
));
73 *-----------------------------------------------------------------------------
76 * Print an string, truncating it to the specified number of characters.
77 * If the string contains newlines, \n is substituted.
79 *-----------------------------------------------------------------------------
82 PrintStr (filePtr
, string
, numChars
)
89 for (idx
= 0; idx
< numChars
; idx
++) {
90 if (string
[idx
] == '\n') {
94 putc (string
[idx
], filePtr
);
96 if (numChars
< strlen (string
))
97 fprintf (filePtr
, "...");
101 *-----------------------------------------------------------------------------
104 * Print an argument string, truncating and adding "..." if its longer
105 * then ARG_TRUNCATE_SIZE. If the string contains white spaces, quote
106 * it with angle brackets.
108 *-----------------------------------------------------------------------------
111 PrintArg (filePtr
, argStr
, noTruncate
)
116 int idx
, argLen
, printLen
;
119 argLen
= strlen (argStr
);
121 if ((!noTruncate
) && (printLen
> ARG_TRUNCATE_SIZE
))
122 printLen
= ARG_TRUNCATE_SIZE
;
124 quote_it
= (printLen
== 0);
126 for (idx
= 0; idx
< printLen
; idx
++)
127 if (isspace (argStr
[idx
])) {
134 PrintStr (filePtr
, argStr
, printLen
);
140 *-----------------------------------------------------------------------------
143 * Print out a trace of a code line. Level is used for indenting
144 * and marking lines and may be eval or procedure level.
146 *-----------------------------------------------------------------------------
149 TraceCode (traceInfoPtr
, level
, command
, argc
, argv
)
150 traceInfo_pt traceInfoPtr
;
156 int idx
, cmdLen
, printLen
;
158 fprintf (traceInfoPtr
->filePtr
, "%2d:", level
);
162 for (idx
= 0; idx
< level
; idx
++)
163 fprintf (traceInfoPtr
->filePtr
, " ");
165 if (traceInfoPtr
->noEval
) {
166 cmdLen
= printLen
= strlen (command
);
167 if ((!traceInfoPtr
->noTruncate
) && (printLen
> CMD_TRUNCATE_SIZE
))
168 printLen
= CMD_TRUNCATE_SIZE
;
170 PrintStr (traceInfoPtr
->filePtr
, command
, printLen
);
172 for (idx
= 0; idx
< argc
; idx
++) {
174 putc (' ', traceInfoPtr
->filePtr
);
175 PrintArg (traceInfoPtr
->filePtr
, argv
[idx
],
176 traceInfoPtr
->noTruncate
);
180 putc ('\n', traceInfoPtr
->filePtr
);
181 if (traceInfoPtr
->flush
)
182 fflush (traceInfoPtr
->filePtr
);
187 *-----------------------------------------------------------------------------
190 * Routine called by Tcl_Eval to trace a command.
192 *-----------------------------------------------------------------------------
195 CmdTraceRoutine (clientData
, interp
, level
, command
, cmdProc
, cmdClientData
,
197 ClientData clientData
;
201 Tcl_CmdProc
*cmdProc
;
202 ClientData cmdClientData
;
206 Interp
*iPtr
= (Interp
*) interp
;
207 traceInfo_pt traceInfoPtr
= (traceInfo_pt
) clientData
;
210 if (!traceInfoPtr
->procCalls
) {
211 TraceCode (traceInfoPtr
, level
, command
, argc
, argv
);
213 if (TclFindProc (iPtr
, argv
[0]) != NULL
) {
214 procLevel
= (iPtr
->varFramePtr
== NULL
) ? 0 :
215 iPtr
->varFramePtr
->level
;
216 TraceCode (traceInfoPtr
, procLevel
, command
, argc
, argv
);
222 *-----------------------------------------------------------------------------
225 * Implements the TCL trace command:
226 * cmdtrace level|on [noeval] [notruncate] [flush] [procs] [filehdl]
231 * Standard TCL results.
233 *-----------------------------------------------------------------------------
236 Tcl_CmdtraceCmd (clientData
, interp
, argc
, argv
)
237 ClientData clientData
;
242 Interp
*iPtr
= (Interp
*) interp
;
243 traceInfo_pt infoPtr
= (traceInfo_pt
) clientData
;
251 * Handle `depth' sub-command.
253 if (STREQU (argv
[1], "depth")) {
256 sprintf(interp
->result
, "%d", infoPtr
->depth
);
261 * If a trace is in progress, delete it now.
263 if (infoPtr
->traceHolder
!= NULL
) {
264 Tcl_DeleteTrace(interp
, infoPtr
->traceHolder
);
266 infoPtr
->traceHolder
= NULL
;
270 * Handle off sub-command.
272 if (STREQU (argv
[1], "off")) {
278 infoPtr
->noEval
= FALSE
;
279 infoPtr
->noTruncate
= FALSE
;
280 infoPtr
->procCalls
= FALSE
;
281 infoPtr
->flush
= FALSE
;
282 infoPtr
->filePtr
= stdout
;
285 for (idx
= 2; idx
< argc
; idx
++) {
286 if (STREQU (argv
[idx
], "notruncate")) {
287 if (infoPtr
->noTruncate
)
289 infoPtr
->noTruncate
= TRUE
;
292 if (STREQU (argv
[idx
], "noeval")) {
295 infoPtr
->noEval
= TRUE
;
298 if (STREQU (argv
[idx
], "flush")) {
301 infoPtr
->flush
= TRUE
;
304 if (STREQU (argv
[idx
], "procs")) {
305 if (infoPtr
->procCalls
)
307 infoPtr
->procCalls
= TRUE
;
310 if (STRNEQU (argv
[idx
], "std", 3) ||
311 STRNEQU (argv
[idx
], "file", 4)) {
312 if (fileHandle
!= NULL
)
314 fileHandle
= argv
[idx
];
320 if (STREQU (argv
[1], "on")) {
321 infoPtr
->depth
= MAXINT
;
323 if (Tcl_GetInt (interp
, argv
[1], &(infoPtr
->depth
)) != TCL_OK
)
326 if (fileHandle
!= NULL
) {
327 OpenFile
*tclFilePtr
;
329 if (TclGetOpenFile (interp
, fileHandle
, &tclFilePtr
) != TCL_OK
)
331 if (!tclFilePtr
->writable
) {
332 Tcl_AppendResult (interp
, "file not writable: ", fileHandle
,
336 infoPtr
->filePtr
= tclFilePtr
->f
;
339 infoPtr
->traceHolder
= Tcl_CreateTrace (interp
, infoPtr
->depth
,
341 (ClientData
) infoPtr
);
345 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
346 " level | on [noeval] [notruncate] [flush] [procs]",
347 "[handle] | off | depth", (char *) NULL
);
351 Tcl_AppendResult (interp
, "invalid option: expected ",
352 "one of \"noeval\", \"notruncate\", \"procs\", ",
353 "\"flush\" or a file handle", (char *) NULL
);
358 *-----------------------------------------------------------------------------
362 * Release the client data area when the trace command is deleted.
364 *-----------------------------------------------------------------------------
367 CleanUpDebug (clientData
)
368 ClientData clientData
;
370 traceInfo_pt infoPtr
= (traceInfo_pt
) clientData
;
372 if (infoPtr
->traceHolder
!= NULL
)
373 Tcl_DeleteTrace (infoPtr
->interp
, infoPtr
->traceHolder
);
374 ckfree ((char *) infoPtr
);
378 *-----------------------------------------------------------------------------
382 * Initialize the TCL debugging commands.
384 *-----------------------------------------------------------------------------
387 Tcl_InitDebug (interp
)
390 traceInfo_pt infoPtr
;
392 infoPtr
= (traceInfo_pt
) ckalloc (sizeof (traceInfo_t
));
394 infoPtr
->interp
= interp
;
395 infoPtr
->traceHolder
= NULL
;
396 infoPtr
->noEval
= FALSE
;
397 infoPtr
->noTruncate
= FALSE
;
398 infoPtr
->procCalls
= FALSE
;
399 infoPtr
->flush
= FALSE
;
402 Tcl_CreateCommand (interp
, "cmdtrace", Tcl_CmdtraceCmd
,
403 (ClientData
)infoPtr
, CleanUpDebug
);