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