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
27 typedef 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 */
44 static void
45 TraceDelete _ANSI_ARGS_((Tcl_Interp *interp,
46 traceInfo_pt infoPtr));
47
48 static void
49 PrintStr _ANSI_ARGS_((Tcl_Channel channel,
50 CONST84 char *string,
51 int numChars,
52 int quoted));
53
54 static void
55 PrintArg _ANSI_ARGS_((Tcl_Channel channel,
56 CONST84 char *argStr,
57 int noTruncate));
58
59 static void
60 TraceCode _ANSI_ARGS_((traceInfo_pt infoPtr,
61 int level,
62 char *command,
63 int argc,
64 CONST84 char **argv));
65
66 static int
67 TraceCallbackErrorHandler _ANSI_ARGS_((ClientData clientData,
68 Tcl_Interp *interp,
69 int code));
70
71 static void
72 TraceCallBack _ANSI_ARGS_((Tcl_Interp *interp,
73 traceInfo_pt infoPtr,
74 int level,
75 char *command,
76 int argc,
77 CONST84 char **argv));
78
79 static void
80 CmdTraceRoutine _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
89 static int
90 TclX_CmdtraceObjCmd _ANSI_ARGS_((ClientData clientData,
91 Tcl_Interp *interp,
92 int objc,
93 Tcl_Obj *CONST objv[]));
94
95 static void
96 DebugCleanUp _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 */
106 static void
TraceDelete(interp,infoPtr)107 TraceDelete (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 */
133 static void
PrintStr(channel,string,numChars,quoted)134 PrintStr (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 */
165 static void
PrintArg(channel,argStr,noTruncate)166 PrintArg (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 */
197 static void
TraceCode(infoPtr,level,command,argc,argv)198 TraceCode (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 */
244 static int
TraceCallbackErrorHandler(clientData,interp,code)245 TraceCallbackErrorHandler (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 */
286 static void
TraceCallBack(interp,infoPtr,level,command,argc,argv)287 TraceCallBack (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 */
349 static void
CmdTraceRoutine(clientData,interp,level,command,cmdProc,cmdClientData,argc,argv)350 CmdTraceRoutine (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 */
402 static int
TclX_CmdtraceObjCmd(clientData,interp,objc,objv)403 TclX_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 */
554 static void
DebugCleanUp(clientData,interp)555 DebugCleanUp (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 */
571 void
TclX_DebugInit(interp)572 TclX_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