git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxdebg.c

   1 /*
   2  * tclXdebug.c --
   3  *
   4  * Tcl command execution trace command.
   5  *-----------------------------------------------------------------------------
   6  * Copyright 1992 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 2.0 1992/10/16 04:50:34 markd Rel $
  16  *-----------------------------------------------------------------------------
  17  */
  18
  19 #include "tclxint.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   traceHolder;
  30     int         noEval;
  31     int         noTruncate;
  32     int         procCalls;
  33     int         flush;
  34     int         depth;
  35     FILE       *filePtr;          /* File to output trace to. */
  36     } traceInfo_t, *traceInfo_pt;
  37
  38 /*
  39  * Prototypes of internal functions.
  40  */
  41 void
  42 PrintStr _ANSI_ARGS_((FILE *filePtr,
  43                       char *string,
  44                       int   numChars));
  45
  46 void
  47 PrintArg _ANSI_ARGS_((FILE *filePtr,
  48                       char *argStr,
  49                       int   noTruncate));
  50
  51 void
  52 TraceCode  _ANSI_ARGS_((traceInfo_pt traceInfoPtr,
  53                         int          level,
  54                         char        *command,
  55                         int          argc,
  56                         char       **argv));
  57
  58 void
  59 CmdTraceRoutine _ANSI_ARGS_((ClientData    clientData,
  60                              Tcl_Interp   *interp,
  61                              int           level,
  62                              char         *command,
  63                              Tcl_CmdProc  *cmdProc,
  64                              ClientData    cmdClientData,
  65                              int           argc,
  66                              char        **argv));
  67
  68 void
  69 CleanUpDebug _ANSI_ARGS_((ClientData clientData));
  70
  71 \f
  72 /*
  73  *-----------------------------------------------------------------------------
  74  *
  75  * PrintStr --
  76  *     Print an string, truncating it to the specified number of characters.
  77  * If the string contains newlines, \n is substituted.
  78  *
  79  *-----------------------------------------------------------------------------
  80  */
  81 void
  82 PrintStr (filePtr, string, numChars)
  83     FILE *filePtr;
  84     char *string;
  85     int   numChars;
  86 {
  87     int idx;
  88
  89     for (idx = 0; idx < numChars; idx++) {
  90         if (string [idx] == '\n') {
  91            putc ('\\', filePtr);
  92            putc ('n', filePtr);
  93         } else
  94            putc (string [idx], filePtr);
  95     }
  96     if (numChars < strlen (string))
  97         fprintf (filePtr, "...");
  98 }
  99 \f
 100 /*
 101  *-----------------------------------------------------------------------------
 102  *
 103  * PrintArg --
 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.
 107  *
 108  *-----------------------------------------------------------------------------
 109  */
 110 void
 111 PrintArg (filePtr, argStr, noTruncate)
 112     FILE *filePtr;
 113     char *argStr;
 114     int   noTruncate;
 115 {
 116     int idx, argLen, printLen;
 117     int quote_it;
 118
 119     argLen = strlen (argStr);
 120     printLen = argLen;
 121     if ((!noTruncate) && (printLen > ARG_TRUNCATE_SIZE))
 122         printLen = ARG_TRUNCATE_SIZE;
 123
 124     quote_it = (printLen == 0);
 125
 126     for (idx = 0; idx < printLen; idx++)
 127         if (isspace (argStr [idx])) {
 128             quote_it = TRUE;
 129             break;
 130         }
 131
 132     if (quote_it)
 133         putc ('{', filePtr);
 134     PrintStr (filePtr, argStr, printLen);
 135     if (quote_it)
 136         putc ('}', filePtr);
 137 }
 138 \f
 139 /*
 140  *-----------------------------------------------------------------------------
 141  *
 142  * TraceCode --
 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.
 145  *
 146  *-----------------------------------------------------------------------------
 147  */
 148 void
 149 TraceCode (traceInfoPtr, level, command, argc, argv)
 150     traceInfo_pt traceInfoPtr;
 151     int          level;
 152     char        *command;
 153     int          argc;
 154     char       **argv;
 155 {
 156     int idx, cmdLen, printLen;
 157
 158     fprintf (traceInfoPtr->filePtr, "%2d:", level);
 159
 160     if (level > 20)
 161         level = 20;
 162     for (idx = 0; idx < level; idx++)
 163         fprintf (traceInfoPtr->filePtr, "  ");
 164
 165     if (traceInfoPtr->noEval) {
 166         cmdLen = printLen = strlen (command);
 167         if ((!traceInfoPtr->noTruncate) && (printLen > CMD_TRUNCATE_SIZE))
 168             printLen = CMD_TRUNCATE_SIZE;
 169
 170         PrintStr (traceInfoPtr->filePtr, command, printLen);
 171       } else {
 172           for (idx = 0; idx < argc; idx++) {
 173               if (idx > 0)
 174                   putc (' ', traceInfoPtr->filePtr);
 175               PrintArg (traceInfoPtr->filePtr, argv[idx],
 176                         traceInfoPtr->noTruncate);
 177           }
 178     }
 179
 180     putc ('\n', traceInfoPtr->filePtr);
 181     if (traceInfoPtr->flush)
 182         fflush (traceInfoPtr->filePtr);
 183
 184 }
 185 \f
 186 /*
 187  *-----------------------------------------------------------------------------
 188  *
 189  * CmdTraceRoutine --
 190  *  Routine called by Tcl_Eval to trace a command.
 191  *
 192  *-----------------------------------------------------------------------------
 193  */
 194 void
 195 CmdTraceRoutine (clientData, interp, level, command, cmdProc, cmdClientData,
 196                  argc, argv)
 197     ClientData    clientData;
 198     Tcl_Interp   *interp;
 199     int           level;
 200     char         *command;
 201     Tcl_CmdProc  *cmdProc;
 202     ClientData    cmdClientData;
 203     int           argc;
 204     char        **argv;
 205 {
 206     Interp       *iPtr = (Interp *) interp;
 207     traceInfo_pt  traceInfoPtr = (traceInfo_pt) clientData;
 208     int           procLevel;
 209
 210     if (!traceInfoPtr->procCalls) {
 211         TraceCode (traceInfoPtr, level, command, argc, argv);
 212     } else {
 213         if (TclFindProc (iPtr, argv [0]) != NULL) {
 214             procLevel = (iPtr->varFramePtr == NULL) ? 0 :
 215                         iPtr->varFramePtr->level;
 216             TraceCode (traceInfoPtr, procLevel, command, argc, argv);
 217         }
 218     }
 219 }
 220 \f
 221 /*
 222  *-----------------------------------------------------------------------------
 223  *
 224  * Tcl_CmdtraceCmd --
 225  *     Implements the TCL trace command:
 226  *     cmdtrace level|on [noeval] [notruncate] [flush] [procs] [filehdl]
 227  *     cmdtrace off
 228  *     cmdtrace depth
 229  *
 230  * Results:
 231  *  Standard TCL results.
 232  *
 233  *-----------------------------------------------------------------------------
 234  */
 235 static int
 236 Tcl_CmdtraceCmd (clientData, interp, argc, argv)
 237     ClientData    clientData;
 238     Tcl_Interp   *interp;
 239     int           argc;
 240     char        **argv;
 241 {
 242     Interp       *iPtr = (Interp *) interp;
 243     traceInfo_pt  infoPtr = (traceInfo_pt) clientData;
 244     int           idx;
 245     char         *fileHandle;
 246
 247     if (argc < 2)
 248         goto argumentError;
 249
 250     /*
 251      * Handle `depth' sub-command.
 252      */
 253     if (STREQU (argv[1], "depth")) {
 254         if (argc != 2)
 255             goto argumentError;
 256         sprintf(interp->result, "%d", infoPtr->depth);
 257         return TCL_OK;
 258     }
 259
 260     /*
 261      * If a trace is in progress, delete it now.
 262      */
 263     if (infoPtr->traceHolder != NULL) {
 264         Tcl_DeleteTrace(interp, infoPtr->traceHolder);
 265         infoPtr->depth = 0;
 266         infoPtr->traceHolder = NULL;
 267     }
 268
 269     /*
 270      * Handle off sub-command.
 271      */
 272     if (STREQU (argv[1], "off")) {
 273         if (argc != 2)
 274             goto argumentError;
 275         return TCL_OK;
 276     }
 277
 278     infoPtr->noEval     = FALSE;
 279     infoPtr->noTruncate = FALSE;
 280     infoPtr->procCalls  = FALSE;
 281     infoPtr->flush      = FALSE;
 282     infoPtr->filePtr    = stdout;
 283     fileHandle          = NULL;
 284
 285     for (idx = 2; idx < argc; idx++) {
 286         if (STREQU (argv[idx], "notruncate")) {
 287             if (infoPtr->noTruncate)
 288                 goto argumentError;
 289             infoPtr->noTruncate = TRUE;
 290             continue;
 291         }
 292         if (STREQU (argv[idx], "noeval")) {
 293             if (infoPtr->noEval)
 294                 goto argumentError;
 295             infoPtr->noEval = TRUE;
 296             continue;
 297         }
 298         if (STREQU (argv[idx], "flush")) {
 299             if (infoPtr->flush)
 300                 goto argumentError;
 301             infoPtr->flush = TRUE;
 302             continue;
 303         }
 304         if (STREQU (argv[idx], "procs")) {
 305             if (infoPtr->procCalls)
 306                 goto argumentError;
 307             infoPtr->procCalls = TRUE;
 308             continue;
 309         }
 310         if (STRNEQU (argv [idx], "std", 3) ||
 311                 STRNEQU (argv [idx], "file", 4)) {
 312             if (fileHandle != NULL)
 313                 goto argumentError;
 314             fileHandle = argv [idx];
 315             continue;
 316         }
 317         goto invalidOption;
 318     }
 319
 320     if (STREQU (argv[1], "on")) {
 321         infoPtr->depth = MAXINT;
 322     } else {
 323         if (Tcl_GetInt (interp, argv[1], &(infoPtr->depth)) != TCL_OK)
 324             return TCL_ERROR;
 325     }
 326     if (fileHandle != NULL) {
 327         OpenFile *tclFilePtr;
 328
 329         if (TclGetOpenFile (interp, fileHandle, &tclFilePtr) != TCL_OK)
 330             return TCL_ERROR;
 331         if (!tclFilePtr->writable) {
 332             Tcl_AppendResult (interp, "file not writable: ", fileHandle,
 333                               (char *) NULL);
 334             return TCL_ERROR;
 335         }
 336         infoPtr->filePtr = tclFilePtr->f;
 337     }
 338
 339     infoPtr->traceHolder = Tcl_CreateTrace (interp, infoPtr->depth,
 340                                             CmdTraceRoutine,
 341                                             (ClientData) infoPtr);
 342     return TCL_OK;
 343
 344 argumentError:
 345     Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
 346                       " level | on [noeval] [notruncate] [flush] [procs]",
 347                       "[handle] | off | depth", (char *) NULL);
 348     return TCL_ERROR;
 349
 350 invalidOption:
 351     Tcl_AppendResult (interp, "invalid option: expected ",
 352                       "one of \"noeval\", \"notruncate\", \"procs\", ",
 353                       "\"flush\" or a file handle", (char *) NULL);
 354     return TCL_ERROR;
 355 }
 356 \f
 357 /*
 358  *-----------------------------------------------------------------------------
 359  *
 360  *  CleanUpDebug --
 361  *
 362  *  Release the client data area when the trace command is deleted.
 363  *
 364  *-----------------------------------------------------------------------------
 365  */
 366 void
 367 CleanUpDebug (clientData)
 368     ClientData clientData;
 369 {
 370     traceInfo_pt infoPtr = (traceInfo_pt) clientData;
 371
 372     if (infoPtr->traceHolder != NULL)
 373         Tcl_DeleteTrace (infoPtr->interp, infoPtr->traceHolder);
 374     ckfree ((char *) infoPtr);
 375 }
 376 \f
 377 /*
 378  *-----------------------------------------------------------------------------
 379  *
 380  *  Tcl_InitDebug --
 381  *
 382  *  Initialize the TCL debugging commands.
 383  *
 384  *-----------------------------------------------------------------------------
 385  */
 386 void
 387 Tcl_InitDebug (interp)
 388     Tcl_Interp *interp;
 389 {
 390     traceInfo_pt infoPtr;
 391
 392     infoPtr = (traceInfo_pt) ckalloc (sizeof (traceInfo_t));
 393
 394     infoPtr->interp      = interp;
 395     infoPtr->traceHolder = NULL;
 396     infoPtr->noEval      = FALSE;
 397     infoPtr->noTruncate  = FALSE;
 398     infoPtr->procCalls   = FALSE;
 399     infoPtr->flush       = FALSE;
 400     infoPtr->depth       = 0;
 401
 402     Tcl_CreateCommand (interp, "cmdtrace", Tcl_CmdtraceCmd,
 403                        (ClientData)infoPtr, CleanUpDebug);
 404 }
 405
 406