expect/Dbg.c

   1 /* Dbg.c - Tcl Debugger - See cmdHelp() for commands
   2
   3 Written by: Don Libes, NIST, 3/23/93
   4
   5 Design and implementation of this program was paid for by U.S. tax
   6 dollars.  Therefore it is public domain.  However, the author and NIST
   7 would appreciate credit if this program or parts of it are used.
   8
   9 */
  10
  11 #include <stdio.h>
  12
  13 #include "Dbg_cf.h"
  14 #if 0
  15 /* tclInt.h drags in stdlib.  By claiming no-stdlib, force it to drag in */
  16 /* Tcl's compat version.  This avoids having to test for its presence */
  17 /* which is too tricky - configure can't generate two cf files, so when */
  18 /* Expect (or any app) uses the debugger, there's no way to get the info */
  19 /* about whether stdlib exists or not, except pointing the debugger at */
  20 /* an app-dependent .h file and I don't want to do that. */
  21 #define NO_STDLIB_H
  22 #endif
  23
  24
  25 #include "tclInt.h"
  26 /*#include <varargs.h>          tclInt.h drags in varargs.h.  Since Pyramid */
  27 /*                              objects to including varargs.h twice, just */
  28 /*                              omit this one. */
  29 /*#include "string.h"           tclInt.h drags this in, too! */
  30 #include "Dbg.h"
  31
  32 #ifndef TRUE
  33 #define TRUE 1
  34 #define FALSE 0
  35 #endif
  36
  37 static int simple_interactor();
  38 static int zero();
  39
  40 /* most of the static variables in this file may be */
  41 /* moved into Tcl_Interp */
  42
  43 static Dbg_InterProc *interactor = simple_interactor;
  44 static ClientData interdata = 0;
  45 static Dbg_IgnoreFuncsProc *ignoreproc = zero;
  46 static Dbg_OutputProc *printproc = 0;
  47 static ClientData printdata = 0;
  48
  49 static void print _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
  50
  51 static int debugger_active = FALSE;
  52
  53 /* this is not externally documented anywhere as of yet */
  54 char *Dbg_VarName = "dbg";
  55
  56 #define DEFAULT_COMPRESS        0
  57 static int compress = DEFAULT_COMPRESS;
  58 #define DEFAULT_WIDTH           75      /* leave a little space for printing */
  59                                         /*  stack level */
  60 static int buf_width = DEFAULT_WIDTH;
  61
  62 static int main_argc = 1;
  63 static char *default_argv = "application";
  64 static char **main_argv = &default_argv;
  65
  66 static Tcl_Trace debug_handle;
  67 static int step_count = 1;      /* count next/step */
  68
  69 #define FRAMENAMELEN 10         /* enough to hold strings like "#4" */
  70 static char viewFrameName[FRAMENAMELEN];/* destination frame name for up/down */
  71
  72 static CallFrame *goalFramePtr; /* destination for next/return */
  73 static int goalNumLevel;        /* destination for Next */
  74
  75 static enum debug_cmd {
  76         none, step, next, ret, cont, up, down, where, Next
  77 } debug_cmd;
  78
  79 /* info about last action to use as a default */
  80 static enum debug_cmd last_action_cmd = next;
  81 static int last_step_count = 1;
  82
  83 /* this acts as a strobe (while testing breakpoints).  It is set to true */
  84 /* every time a new debugger command is issued that is an action */
  85 static debug_new_action;
  86
  87 #define NO_LINE -1      /* if break point is not set by line number */
  88
  89 struct breakpoint {
  90         int id;
  91         char *file;     /* file where breakpoint is */
  92         int line;       /* line where breakpoint is */
  93         char *pat;      /* pattern defining where breakpoint can be */
  94         regexp *re;     /* regular expression to trigger breakpoint */
  95         char *expr;     /* expr to trigger breakpoint */
  96         char *cmd;      /* cmd to eval at breakpoint */
  97         struct breakpoint *next, *previous;
  98 };
  99
 100 static struct breakpoint *break_base = 0;
 101 static int breakpoint_max_id = 0;
 102
 103 static struct breakpoint *
 104 breakpoint_new()
 105 {
 106         struct breakpoint *b = (struct breakpoint *)ckalloc(sizeof(struct breakpoint));
 107         if (break_base) break_base->previous = b;
 108         b->next = break_base;
 109         b->previous = 0;
 110         b->id = breakpoint_max_id++;
 111         b->file = 0;
 112         b->line = NO_LINE;
 113         b->pat = 0;
 114         b->re = 0;
 115         b->expr = 0;
 116         b->cmd = 0;
 117         break_base = b;
 118         return(b);
 119 }
 120
 121 static
 122 void
 123 breakpoint_print(interp,b)
 124 Tcl_Interp *interp;
 125 struct breakpoint *b;
 126 {
 127         print(interp,"breakpoint %d: ",b->id);
 128
 129         if (b->re) {
 130                 print(interp,"-re \"%s\" ",b->pat);
 131         } else if (b->pat) {
 132                 print(interp,"-glob \"%s\" ",b->pat);
 133         } else if (b->line != NO_LINE) {
 134                 if (b->file) {
 135                         print(interp,"%s:",b->file);
 136                 }
 137                 print(interp,"%d ",b->line);
 138         }
 139
 140         if (b->expr)
 141                 print(interp,"if {%s} ",b->expr);
 142
 143         if (b->cmd)
 144                 print(interp,"then {%s}",b->cmd);
 145
 146         print(interp,"\n");
 147 }
 148
 149 static void
 150 save_re_matches(interp,re)
 151 Tcl_Interp *interp;
 152 regexp *re;
 153 {
 154         int i;
 155         char name[20];
 156         char match_char;/* place to hold char temporarily */
 157                         /* uprooted by a NULL */
 158
 159         for (i=0;i<NSUBEXP;i++) {
 160                 if (re->startp[i] == 0) break;
 161
 162                 sprintf(name,"%d",i);
 163                 /* temporarily null-terminate in middle */
 164                 match_char = *re->endp[i];
 165                 *re->endp[i] = 0;
 166                 Tcl_SetVar2(interp,Dbg_VarName,name,re->startp[i],0);
 167
 168                 /* undo temporary null-terminator */
 169                 *re->endp[i] = match_char;
 170         }
 171 }
 172
 173 /* return 1 to break, 0 to continue */
 174 static int
 175 breakpoint_test(interp,cmd,bp)
 176 Tcl_Interp *interp;
 177 char *cmd;              /* command about to be executed */
 178 struct breakpoint *bp;  /* breakpoint to test */
 179 {
 180         if (bp->re) {
 181                 if (0 == TclRegExec(bp->re,cmd,cmd)) return 0;
 182                 save_re_matches(interp,bp->re);
 183         } else if (bp->pat) {
 184                 if (0 == Tcl_StringMatch(cmd,bp->pat)) return 0;
 185         } else if (bp->line != NO_LINE) {
 186                 /* not yet implemented - awaiting support from Tcl */
 187                 return 0;
 188         }
 189
 190         if (bp->expr) {
 191                 int value;
 192
 193                 /* ignore errors, since they are likely due to */
 194                 /* simply being out of scope a lot */
 195                 if (TCL_OK != Tcl_ExprBoolean(interp,bp->expr,&value)
 196                     || (value == 0)) return 0;
 197         }
 198
 199         if (bp->cmd) {
 200                 Tcl_Eval(interp,bp->cmd);
 201         } else {
 202                 breakpoint_print(interp,bp);
 203         }
 204
 205         return 1;
 206 }
 207
 208 static char *already_at_top_level = "already at top level";
 209
 210 /* similar to TclGetFrame but takes two frame ptrs and a direction.
 211 If direction is up,   search up stack from curFrame
 212 If direction is down, simulate searching down stack by
 213                       seaching up stack from origFrame
 214 */
 215 static
 216 int
 217 TclGetFrame2(interp, origFramePtr, string, framePtrPtr, dir)
 218     Tcl_Interp *interp;
 219     CallFrame *origFramePtr;    /* frame that is true top-of-stack */
 220     char *string;               /* String describing frame. */
 221     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
 222                                  * if global frame indicated). */
 223     enum debug_cmd dir; /* look up or down the stack */
 224 {
 225     Interp *iPtr = (Interp *) interp;
 226     int level, result;
 227     CallFrame *framePtr;        /* frame currently being searched */
 228
 229     CallFrame *curFramePtr = iPtr->varFramePtr;
 230
 231     /*
 232      * Parse string to figure out which level number to go to.
 233      */
 234
 235     result = 1;
 236     if (*string == '#') {
 237         if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
 238             return TCL_ERROR;
 239         }
 240         if (level < 0) {
 241             levelError:
 242             Tcl_AppendResult(interp, "bad level \"", string, "\"",
 243                     (char *) NULL);
 244             return TCL_ERROR;
 245         }
 246         framePtr = origFramePtr; /* start search here */
 247
 248     } else if (isdigit(*string)) {
 249         if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
 250             return TCL_ERROR;
 251         }
 252         if (dir == up) {
 253                 if (curFramePtr == 0) {
 254                         Tcl_SetResult(interp,already_at_top_level,TCL_STATIC);
 255                         return TCL_ERROR;
 256                 }
 257                 level = curFramePtr->level - level;
 258                 framePtr = curFramePtr; /* start search here */
 259         } else {
 260                 if (curFramePtr != 0) {
 261                         level = curFramePtr->level + level;
 262                 }
 263                 framePtr = origFramePtr; /* start search here */
 264         }
 265     } else {
 266         level = curFramePtr->level - 1;
 267         result = 0;
 268     }
 269
 270     /*
 271      * Figure out which frame to use.
 272      */
 273
 274     if (level == 0) {
 275         framePtr = NULL;
 276     } else {
 277         for (;framePtr != NULL; framePtr = framePtr->callerVarPtr) {
 278             if (framePtr->level == level) {
 279                 break;
 280             }
 281         }
 282         if (framePtr == NULL) {
 283             goto levelError;
 284         }
 285     }
 286     *framePtrPtr = framePtr;
 287     return result;
 288 }
 289
 290
 291 static char *printify(s)
 292 char *s;
 293 {
 294         static int destlen = 0;
 295         char *d;                /* ptr into dest */
 296         unsigned int need;
 297         static char buf_basic[DEFAULT_WIDTH+1];
 298         static char *dest = buf_basic;
 299
 300         if (s == 0) return("<null>");
 301
 302         /* worst case is every character takes 4 to printify */
 303         need = strlen(s)*4;
 304         if (need > destlen) {
 305                 if (dest && (dest != buf_basic)) ckfree(dest);
 306                 dest = (char *)ckalloc(need+1);
 307                 destlen = need;
 308         }
 309
 310         for (d = dest;*s;s++) {
 311                 /* since we check at worst by every 4 bytes, play */
 312                 /* conservative and subtract 4 from the limit */
 313                 if (d-dest > destlen-4) break;
 314
 315                 if (*s == '\b') {
 316                         strcpy(d,"\\b");                d += 2;
 317                 } else if (*s == '\f') {
 318                         strcpy(d,"\\f");                d += 2;
 319                 } else if (*s == '\v') {
 320                         strcpy(d,"\\v");                d += 2;
 321                 } else if (*s == '\r') {
 322                         strcpy(d,"\\r");                d += 2;
 323                 } else if (*s == '\n') {
 324                         strcpy(d,"\\n");                d += 2;
 325                 } else if (*s == '\t') {
 326                         strcpy(d,"\\t");                d += 2;
 327                 } else if ((unsigned)*s < 0x20) { /* unsigned strips parity */
 328                         sprintf(d,"\\%03o",*s);         d += 4;
 329                 } else if (*s == 0177) {
 330                         strcpy(d,"\\177");              d += 4;
 331                 } else {
 332                         *d = *s;                        d += 1;
 333                 }
 334         }
 335         *d = '\0';
 336         return(dest);
 337 }
 338
 339 static
 340 char *
 341 print_argv(interp,argc,argv)
 342 Tcl_Interp *interp;
 343 int argc;
 344 char *argv[];
 345 {
 346         static int buf_width_max = DEFAULT_WIDTH;
 347         static char buf_basic[DEFAULT_WIDTH+1]; /* basic buffer */
 348         static char *buf = buf_basic;
 349         int space;              /* space remaining in buf */
 350         int len;
 351         char *bufp;
 352         int proc;               /* if current command is "proc" */
 353         int arg_index;
 354
 355         if (buf_width > buf_width_max) {
 356                 if (buf && (buf != buf_basic)) ckfree(buf);
 357                 buf = (char *)ckalloc(buf_width + 1);
 358                 buf_width_max = buf_width;
 359         }
 360
 361         proc = (0 == strcmp("proc",argv[0]));
 362         sprintf(buf,"%.*s",buf_width,argv[0]);
 363         len = strlen(buf);
 364         space = buf_width - len;
 365         bufp = buf + len;
 366         argc--; argv++;
 367         arg_index = 1;
 368
 369         while (argc && (space > 0)) {
 370                 char *elementPtr;
 371                 char *nextPtr;
 372                 int wrap;
 373
 374                 /* braces/quotes have been stripped off arguments */
 375                 /* so put them back.  We wrap everything except lists */
 376                 /* with one argument.  One exception is to always wrap */
 377                 /* proc's 2nd arg (the arg list), since people are */
 378                 /* used to always seeing it this way. */
 379
 380                 if (proc && (arg_index > 1)) wrap = TRUE;
 381                 else {
 382                         (void) TclFindElement(interp,*argv,
 383 #if TCL_MAJOR_VERSION >= 8
 384                                               -1,
 385 #endif
 386                        &elementPtr,&nextPtr,(int *)0,(int *)0);
 387                         if (*elementPtr == '\0') wrap = TRUE;
 388                         else if (*nextPtr == '\0') wrap = FALSE;
 389                         else wrap = TRUE;
 390                 }
 391
 392                 /* wrap lists (or null) in braces */
 393                 if (wrap) {
 394                         sprintf(bufp," {%.*s}",space-3,*argv);
 395                 } else {
 396                         sprintf(bufp," %.*s",space-1,*argv);
 397                 }
 398                 len = strlen(buf);
 399                 space = buf_width - len;
 400                 bufp = buf + len;
 401                 argc--; argv++;
 402                 arg_index++;
 403         }
 404
 405         if (compress) {
 406                 /* this copies from our static buf to printify's static buf */
 407                 /* and back to our static buf */
 408                 strncpy(buf,printify(buf),buf_width);
 409         }
 410
 411         /* usually but not always right, but assume truncation if buffer is */
 412         /* full.  this avoids tiny but odd-looking problem of appending "}" */
 413         /* to truncated lists during {}-wrapping earlier */
 414         if (strlen(buf) == buf_width) {
 415                 buf[buf_width-1] = buf[buf_width-2] = buf[buf_width-3] = '.';
 416         }
 417
 418         return(buf);
 419 }
 420
 421 #if TCL_MAJOR_VERSION >= 8
 422 static
 423 char *
 424 print_objv(interp,objc,objv)
 425 Tcl_Interp *interp;
 426 int objc;
 427 Tcl_Obj *objv[];
 428 {
 429     char **argv;
 430     int argc;
 431     int len;
 432     argv = (char **)ckalloc(objc+1 * sizeof(char *));
 433     for (argc=0 ; argc<objc ; argc++) {
 434         argv[argc] = Tcl_GetStringFromObj(objv[argc],&len);
 435     }
 436     argv[argc] = NULL;
 437     print_argv(interp,argc,argv);
 438 }
 439 #endif
 440
 441 static
 442 void
 443 PrintStackBelow(interp,curf,viewf)
 444 Tcl_Interp *interp;
 445 CallFrame *curf;        /* current FramePtr */
 446 CallFrame *viewf;       /* view FramePtr */
 447 {
 448         char ptr;       /* graphically indicate where we are in the stack */
 449
 450         /* indicate where we are in the stack */
 451         ptr = ((curf == viewf)?'*':' ');
 452
 453         if (curf == 0) {
 454                 print(interp,"%c0: %s\n",
 455                                 ptr,print_argv(interp,main_argc,main_argv));
 456         } else {
 457                 PrintStackBelow(interp,curf->callerVarPtr,viewf);
 458                 print(interp,"%c%d: %s\n",ptr,curf->level,
 459 #if TCL_MAJOR_VERSION >= 8
 460                         print_objv(interp,curf->objc,curf->objv));
 461 #else
 462                         print_argv(interp,curf->argc,curf->argv));
 463 #endif
 464         }
 465 }
 466
 467 static
 468 void
 469 PrintStack(interp,curf,viewf,argc,argv,level)
 470 Tcl_Interp *interp;
 471 CallFrame *curf;        /* current FramePtr */
 472 CallFrame *viewf;       /* view FramePtr */
 473 int argc;
 474 char *argv[];
 475 char *level;
 476 {
 477         PrintStackBelow(interp,curf,viewf);
 478
 479         print(interp," %s: %s\n",level,print_argv(interp,argc,argv));
 480 }
 481
 482 /* return 0 if goal matches current frame or goal can't be found */
 483 /*      anywere in frame stack */
 484 /* else return 1 */
 485 /* This catches things like a proc called from a Tcl_Eval which in */
 486 /* turn was not called from a proc but some builtin such as source */
 487 /* or Tcl_Eval.  These builtin calls to Tcl_Eval lose any knowledge */
 488 /* the FramePtr from the proc, so we have to search the entire */
 489 /* stack frame to see if it's still there. */
 490 static int
 491 GoalFrame(goal,iptr)
 492 CallFrame *goal;
 493 Interp *iptr;
 494 {
 495         CallFrame *cf = iptr->varFramePtr;
 496
 497         /* if at current level, return success immediately */
 498         if (goal == cf) return 0;
 499
 500         while (cf) {
 501                 cf = cf->callerVarPtr;
 502                 if (goal == cf) {
 503                         /* found, but since it's above us, fail */
 504                         return 1;
 505                 }
 506         }
 507         return 0;
 508 }
 509
 510 /* debugger's trace handler */
 511 /*ARGSUSED*/
 512 static void
 513 debugger_trap(clientData,interp,level,command,cmdProc,cmdClientData,argc,argv)
 514 ClientData clientData;          /* not used */
 515 Tcl_Interp *interp;
 516 int level;                      /* positive number if called by Tcl, -1 if */
 517                                 /* called by Dbg_On in which case we don't */
 518                                 /* know the level */
 519 char *command;
 520 int (*cmdProc)();               /* not used */
 521 ClientData cmdClientData;
 522 int argc;
 523 char *argv[];
 524 {
 525         char level_text[6];     /* textual representation of level */
 526
 527         int break_status;
 528         Interp *iPtr = (Interp *)interp;
 529
 530         CallFrame *trueFramePtr;        /* where the pc is */
 531         CallFrame *viewFramePtr;        /* where up/down are */
 532
 533         int print_command_first_time = TRUE;
 534         static int debug_suspended = FALSE;
 535
 536         struct breakpoint *b;
 537
 538         /* skip commands that are invoked interactively */
 539         if (debug_suspended) return;
 540
 541         /* skip debugger commands */
 542         if (argv[0][1] == '\0') {
 543                 switch (argv[0][0]) {
 544                 case 'n':
 545                 case 's':
 546                 case 'c':
 547                 case 'r':
 548                 case 'w':
 549                 case 'b':
 550                 case 'u':
 551                 case 'd': return;
 552                 }
 553         }
 554
 555         if ((*ignoreproc)(interp,argv[0])) return;
 556
 557         /* if level is unknown, use "?" */
 558         sprintf(level_text,(level == -1)?"?":"%d",level);
 559
 560         /* save so we can restore later */
 561         trueFramePtr = iPtr->varFramePtr;
 562
 563         /* do not allow breaking while testing breakpoints */
 564         debug_suspended = TRUE;
 565
 566         /* test all breakpoints to see if we should break */
 567         /* if any successful breakpoints, start interactor */
 568         debug_new_action = FALSE;       /* reset strobe */
 569         break_status = FALSE;           /* no successful breakpoints yet */
 570         for (b = break_base;b;b=b->next) {
 571                 break_status |= breakpoint_test(interp,command,b);
 572         }
 573         if (break_status) {
 574                 if (!debug_new_action) goto start_interact;
 575
 576                 /* if s or n triggered by breakpoint, make "s 1" */
 577                 /* (and so on) refer to next command, not this one */
 578 /*              step_count++;*/
 579                 goto end_interact;
 580         }
 581
 582         switch (debug_cmd) {
 583         case cont:
 584                 goto finish;
 585         case step:
 586                 step_count--;
 587                 if (step_count > 0) goto finish;
 588                 goto start_interact;
 589         case next:
 590                 /* check if we are back at the same level where the next */
 591                 /* command was issued.  Also test */
 592                 /* against all FramePtrs and if no match, assume that */
 593                 /* we've missed a return, and so we should break  */
 594 /*              if (goalFramePtr != iPtr->varFramePtr) goto finish;*/
 595                 if (GoalFrame(goalFramePtr,iPtr)) goto finish;
 596                 step_count--;
 597                 if (step_count > 0) goto finish;
 598                 goto start_interact;
 599         case Next:
 600                 /* check if we are back at the same level where the next */
 601                 /* command was issued.  */
 602                 if (goalNumLevel < iPtr->numLevels) goto finish;
 603                 step_count--;
 604                 if (step_count > 0) goto finish;
 605                 goto start_interact;
 606         case ret:
 607                 /* same comment as in "case next" */
 608                 if (goalFramePtr != iPtr->varFramePtr) goto finish;
 609                 goto start_interact;
 610         }
 611
 612 start_interact:
 613         if (print_command_first_time) {
 614                 print(interp,"%s: %s\n",
 615                                 level_text,print_argv(interp,1,&command));
 616                 print_command_first_time = FALSE;
 617         }
 618         /* since user is typing a command, don't interrupt it immediately */
 619         debug_cmd = cont;
 620         debug_suspended = TRUE;
 621
 622         /* interactor won't return until user gives a debugger cmd */
 623         (*interactor)(interp,interdata);
 624 end_interact:
 625
 626         /* save this so it can be restored after "w" command */
 627         viewFramePtr = iPtr->varFramePtr;
 628
 629         if (debug_cmd == up || debug_cmd == down) {
 630                 /* calculate new frame */
 631                 if (-1 == TclGetFrame2(interp,trueFramePtr,viewFrameName,
 632                                         &iPtr->varFramePtr,debug_cmd)) {
 633                         print(interp,"%s\n",interp->result);
 634                         Tcl_ResetResult(interp);
 635                 }
 636                 goto start_interact;
 637         }
 638
 639         /* reset view back to normal */
 640         iPtr->varFramePtr = trueFramePtr;
 641
 642 #if 0
 643         /* allow trapping */
 644         debug_suspended = FALSE;
 645 #endif
 646
 647         switch (debug_cmd) {
 648         case cont:
 649         case step:
 650                 goto finish;
 651         case next:
 652                 goalFramePtr = iPtr->varFramePtr;
 653                 goto finish;
 654         case Next:
 655                 goalNumLevel = iPtr->numLevels;
 656                 goto finish;
 657         case ret:
 658                 goalFramePtr = iPtr->varFramePtr;
 659                 if (goalFramePtr == 0) {
 660                         print(interp,"nowhere to return to\n");
 661                         break;
 662                 }
 663                 goalFramePtr = goalFramePtr->callerVarPtr;
 664                 goto finish;
 665         case where:
 666                 PrintStack(interp,iPtr->varFramePtr,viewFramePtr,argc,argv,level_text);
 667                 break;
 668         }
 669
 670         /* restore view and restart interactor */
 671         iPtr->varFramePtr = viewFramePtr;
 672         goto start_interact;
 673
 674  finish:
 675         debug_suspended = FALSE;
 676 }
 677
 678 /*ARGSUSED*/
 679 static
 680 int
 681 cmdNext(clientData, interp, argc, argv)
 682 ClientData clientData;
 683 Tcl_Interp *interp;
 684 int argc;
 685 char **argv;
 686 {
 687         debug_new_action = TRUE;
 688         debug_cmd = *(enum debug_cmd *)clientData;
 689         last_action_cmd = debug_cmd;
 690
 691         step_count = (argc == 1)?1:atoi(argv[1]);
 692         last_step_count = step_count;
 693         return(TCL_RETURN);
 694 }
 695
 696 /*ARGSUSED*/
 697 static
 698 int
 699 cmdDir(clientData, interp, argc, argv)
 700 ClientData clientData;
 701 Tcl_Interp *interp;
 702 int argc;
 703 char **argv;
 704 {
 705         debug_cmd = *(enum debug_cmd *)clientData;
 706
 707         if (argc == 1) argv[1] = "1";
 708         strncpy(viewFrameName,argv[1],FRAMENAMELEN);
 709
 710         return TCL_RETURN;
 711 }
 712
 713 /*ARGSUSED*/
 714 static
 715 int
 716 cmdSimple(clientData, interp, argc, argv)
 717 ClientData clientData;
 718 Tcl_Interp *interp;
 719 int argc;
 720 char **argv;
 721 {
 722         debug_new_action = TRUE;
 723         debug_cmd = *(enum debug_cmd *)clientData;
 724         last_action_cmd = debug_cmd;
 725
 726         return TCL_RETURN;
 727 }
 728
 729 static
 730 void
 731 breakpoint_destroy(b)
 732 struct breakpoint *b;
 733 {
 734         if (b->file) ckfree(b->file);
 735         if (b->pat) ckfree(b->pat);
 736         if (b->re) ckfree((char *)b->re);
 737         if (b->cmd) ckfree(b->cmd);
 738
 739         /* unlink from chain */
 740         if ((b->previous == 0) && (b->next == 0)) {
 741                 break_base = 0;
 742         } else if (b->previous == 0) {
 743                 break_base = b->next;
 744                 b->next->previous = 0;
 745         } else if (b->next == 0) {
 746                 b->previous->next = 0;
 747         } else {
 748                 b->previous->next = b->next;
 749                 b->next->previous = b->previous;
 750         }
 751
 752         ckfree((char *)b);
 753 }
 754
 755 static void
 756 savestr(straddr,str)
 757 char **straddr;
 758 char *str;
 759 {
 760         *straddr = ckalloc(strlen(str)+1);
 761         strcpy(*straddr,str);
 762 }
 763
 764 /* return 1 if a string is substring of a flag */
 765 static int
 766 flageq(flag,string,minlen)
 767 char *flag;
 768 char *string;
 769 int minlen;             /* at least this many chars must match */
 770 {
 771         for (;*flag;flag++,string++,minlen--) {
 772                 if (*string == '\0') break;
 773                 if (*string != *flag) return 0;
 774         }
 775         if (*string == '\0' && minlen <= 0) return 1;
 776         return 0;
 777 }
 778
 779 /*ARGSUSED*/
 780 static
 781 int
 782 cmdWhere(clientData, interp, argc, argv)
 783 ClientData clientData;
 784 Tcl_Interp *interp;
 785 int argc;
 786 char **argv;
 787 {
 788         if (argc == 1) {
 789                 debug_cmd = where;
 790                 return TCL_RETURN;
 791         }
 792
 793         argc--; argv++;
 794
 795         while (argc) {
 796                 if (flageq("-width",*argv,2)) {
 797                         argc--; argv++;
 798                         if (*argv) {
 799                                 buf_width = atoi(*argv);
 800                                 argc--; argv++;
 801                         } else print(interp,"%d\n",buf_width);
 802                 } else if (flageq("-compress",*argv,2)) {
 803                         argc--; argv++;
 804                         if (*argv) {
 805                                 compress = atoi(*argv);
 806                                 argc--; argv++;
 807                         } else print(interp,"%d\n",compress);
 808                 } else {
 809                         print(interp,"usage: w [-width #] [-compress 0|1]\n");
 810                         return TCL_ERROR;
 811                 }
 812         }
 813         return TCL_OK;
 814 }
 815
 816 #define breakpoint_fail(msg) {error_msg = msg; goto break_fail;}
 817
 818 /*ARGSUSED*/
 819 static
 820 int
 821 cmdBreak(clientData, interp, argc, argv)
 822 ClientData clientData;
 823 Tcl_Interp *interp;
 824 int argc;
 825 char **argv;
 826 {
 827         struct breakpoint *b;
 828         char *error_msg;
 829
 830         argc--; argv++;
 831
 832         if (argc < 1) {
 833                 for (b = break_base;b;b=b->next) breakpoint_print(interp,b);
 834                 return(TCL_OK);
 835         }
 836
 837         if (argv[0][0] == '-') {
 838                 if (argv[0][1] == '\0') {
 839                         while (break_base) {
 840                                 breakpoint_destroy(break_base);
 841                         }
 842                         breakpoint_max_id = 0;
 843                         return(TCL_OK);
 844                 } else if (isdigit(argv[0][1])) {
 845                         int id = atoi(argv[0]+1);
 846
 847                         for (b = break_base;b;b=b->next) {
 848                                 if (b->id == id) {
 849                                         breakpoint_destroy(b);
 850                                         if (!break_base) breakpoint_max_id = 0;
 851                                         return(TCL_OK);
 852                                 }
 853                         }
 854                         Tcl_SetResult(interp,"no such breakpoint",TCL_STATIC);
 855                         return(TCL_ERROR);
 856                 }
 857         }
 858
 859         b = breakpoint_new();
 860
 861         if (flageq("-regexp",argv[0],2)) {
 862                 argc--; argv++;
 863                 if ((argc > 0) && (b->re = TclRegComp(argv[0]))) {
 864                         savestr(&b->pat,argv[0]);
 865                         argc--; argv++;
 866                 } else {
 867                         breakpoint_fail("bad regular expression")
 868                 }
 869         } else if (flageq("-glob",argv[0],2)) {
 870                 argc--; argv++;
 871                 if (argc > 0) {
 872                         savestr(&b->pat,argv[0]);
 873                         argc--; argv++;
 874                 } else {
 875                         breakpoint_fail("no pattern?");
 876                 }
 877         } else if ((!(flageq("if",*argv,1)) && (!(flageq("then",*argv,1))))) {
 878                 /* look for [file:]line */
 879                 char *colon;
 880                 char *linep;    /* pointer to beginning of line number */
 881
 882                 colon = strchr(argv[0],':');
 883                 if (colon) {
 884                         *colon = '\0';
 885                         savestr(&b->file,argv[0]);
 886                         *colon = ':';
 887                         linep = colon + 1;
 888                 } else {
 889                         linep = argv[0];
 890                         /* get file from current scope */
 891                         /* savestr(&b->file, ?); */
 892                 }
 893
 894                 if (TCL_OK == Tcl_GetInt(interp,linep,&b->line)) {
 895                         argc--; argv++;
 896                         print(interp,"setting breakpoints by line number is currently unimplemented - use patterns or expressions\n");
 897                 } else {
 898                         /* not an int? - unwind & assume it is an expression */
 899
 900                         if (b->file) ckfree(b->file);
 901                 }
 902         }
 903
 904         if (argc > 0) {
 905                 int do_if = FALSE;
 906
 907                 if (flageq("if",argv[0],1)) {
 908                         argc--; argv++;
 909                         do_if = TRUE;
 910                 } else if (!flageq("then",argv[0],1)) {
 911                         do_if = TRUE;
 912                 }
 913
 914                 if (do_if) {
 915                         if (argc < 1) {
 916                                 breakpoint_fail("if what");
 917                         }
 918
 919                         savestr(&b->expr,argv[0]);
 920                         argc--; argv++;
 921                 }
 922         }
 923
 924         if (argc > 0) {
 925                 if (flageq("then",argv[0],1)) {
 926                         argc--; argv++;
 927                 }
 928
 929                 if (argc < 1) {
 930                         breakpoint_fail("then what?");
 931                 }
 932
 933                 savestr(&b->cmd,argv[0]);
 934         }
 935
 936         sprintf(interp->result,"%d",b->id);
 937         return(TCL_OK);
 938
 939  break_fail:
 940         breakpoint_destroy(b);
 941         Tcl_SetResult(interp,error_msg,TCL_STATIC);
 942         return(TCL_ERROR);
 943 }
 944
 945 static char *help[] = {
 946 "s [#]          step into procedure",
 947 "n [#]          step over procedure",
 948 "N [#]          step over procedures, commands, and arguments",
 949 "c              continue",
 950 "r              continue until return to caller",
 951 "u [#]          move scope up level",
 952 "d [#]          move scope down level",
 953 "               go to absolute frame if # is prefaced by \"#\"",
 954 "w              show stack (\"where\")",
 955 "w -w [#]       show/set width",
 956 "w -c [0|1]     show/set compress",
 957 "b              show breakpoints",
 958 "b [-r regexp-pattern] [if expr] [then command]",
 959 "b [-g glob-pattern]   [if expr] [then command]",
 960 "b [[file:]#]          [if expr] [then command]",
 961 "               if pattern given, break if command resembles pattern",
 962 "               if # given, break on line #",
 963 "               if expr given, break if expr true",
 964 "               if command given, execute command at breakpoint",
 965 "b -#           delete breakpoint",
 966 "b -            delete all breakpoints",
 967 0};
 968
 969 /*ARGSUSED*/
 970 static
 971 int
 972 cmdHelp(clientData, interp, argc, argv)
 973 ClientData clientData;
 974 Tcl_Interp *interp;
 975 int argc;
 976 char **argv;
 977 {
 978         char **hp;
 979
 980         for (hp=help;*hp;hp++) {
 981                 print(interp,"%s\n",*hp);
 982         }
 983
 984         return(TCL_OK);
 985 }
 986
 987 /* occasionally, we print things larger buf_max but not by much */
 988 /* see print statements in PrintStack routines for examples */
 989 #define PAD 80
 990
 991 /*VARARGS*/
 992 static void
 993 print TCL_VARARGS_DEF(Tcl_Interp *,arg1)
 994 {
 995         Tcl_Interp *interp;
 996         char *fmt;
 997         va_list args;
 998
 999         interp = TCL_VARARGS_START(Tcl_Interp *,arg1,args);
1000         fmt = va_arg(args,char *);
1001         if (!printproc) vprintf(fmt,args);
1002         else {
1003                 static int buf_width_max = DEFAULT_WIDTH+PAD;
1004                 static char buf_basic[DEFAULT_WIDTH+PAD+1];
1005                 static char *buf = buf_basic;
1006
1007                 if (buf_width+PAD > buf_width_max) {
1008                         if (buf && (buf != buf_basic)) ckfree(buf);
1009                         buf = (char *)ckalloc(buf_width+PAD+1);
1010                         buf_width_max = buf_width+PAD;
1011                 }
1012
1013                 vsprintf(buf,fmt,args);
1014                 (*printproc)(interp,buf,printdata);
1015         }
1016         va_end(args);
1017 }
1018
1019 /*ARGSUSED*/
1020 Dbg_InterStruct
1021 Dbg_Interactor(interp,inter_proc,data)
1022 Tcl_Interp *interp;
1023 Dbg_InterProc *inter_proc;
1024 ClientData data;
1025 {
1026         Dbg_InterStruct tmp;
1027
1028         tmp.func = interactor;
1029         tmp.data = interdata;
1030         interactor = (inter_proc?inter_proc:simple_interactor);
1031         interdata = data;
1032         return tmp;
1033 }
1034
1035 /*ARGSUSED*/
1036 Dbg_IgnoreFuncsProc *
1037 Dbg_IgnoreFuncs(interp,proc)
1038 Tcl_Interp *interp;
1039 Dbg_IgnoreFuncsProc *proc;
1040 {
1041         Dbg_IgnoreFuncsProc *tmp = ignoreproc;
1042         ignoreproc = (proc?proc:zero);
1043         return tmp;
1044 }
1045
1046 /*ARGSUSED*/
1047 Dbg_OutputStruct
1048 Dbg_Output(interp,proc,data)
1049 Tcl_Interp *interp;
1050 Dbg_OutputProc *proc;
1051 ClientData data;
1052 {
1053         Dbg_OutputStruct tmp;
1054
1055         tmp.func = printproc;
1056         tmp.data = printdata;
1057         printproc = proc;
1058         printdata = data;
1059         return tmp;
1060 }
1061
1062 /*ARGSUSED*/
1063 int
1064 Dbg_Active(interp)
1065 Tcl_Interp *interp;
1066 {
1067         return debugger_active;
1068 }
1069
1070 char **
1071 Dbg_ArgcArgv(argc,argv,copy)
1072 int argc;
1073 char *argv[];
1074 int copy;
1075 {
1076         char **alloc;
1077
1078         main_argc = argc;
1079
1080         if (!copy) {
1081                 main_argv = argv;
1082                 alloc = 0;
1083         } else {
1084                 main_argv = alloc = (char **)ckalloc((argc+1)*sizeof(char *));
1085                 while (argc-- >= 0) {
1086                         *main_argv++ = *argv++;
1087                 }
1088                 main_argv = alloc;
1089         }
1090         return alloc;
1091 }
1092
1093 static struct cmd_list {
1094         char *cmdname;
1095         Tcl_CmdProc *cmdproc;
1096         enum debug_cmd cmdtype;
1097 } cmd_list[]  = {
1098                 {"n", cmdNext,   next},
1099                 {"s", cmdNext,   step},
1100                 {"N", cmdNext,   Next},
1101                 {"c", cmdSimple, cont},
1102                 {"r", cmdSimple, ret},
1103                 {"w", cmdWhere,  none},
1104                 {"b", cmdBreak,  none},
1105                 {"u", cmdDir,    up},
1106                 {"d", cmdDir,    down},
1107                 {"h", cmdHelp,   none},
1108                 {0}
1109 };
1110
1111 /* this may seem excessive, but this avoids the explicit test for non-zero */
1112 /* in the caller, and chances are that that test will always be pointless */
1113 /*ARGSUSED*/
1114 static int zero(interp,string)
1115 Tcl_Interp *interp;
1116 char *string;
1117 {
1118         return 0;
1119 }
1120
1121 static int
1122 simple_interactor(interp)
1123 Tcl_Interp *interp;
1124 {
1125         int rc;
1126         char *ccmd;             /* pointer to complete command */
1127         char line[BUFSIZ+1];    /* space for partial command */
1128         int newcmd = TRUE;
1129         Interp *iPtr = (Interp *)interp;
1130
1131         Tcl_DString dstring;
1132         Tcl_DStringInit(&dstring);
1133
1134         newcmd = TRUE;
1135         while (TRUE) {
1136                 struct cmd_list *c;
1137
1138                 if (newcmd) {
1139 #if TCL_MAJOR_VERSION < 8
1140                         print(interp,"dbg%d.%d> ",iPtr->numLevels,iPtr->curEventNum+1);
1141 #else
1142                         /* unncessarily tricky coding - if nextid
1143                            isn't defined, maintain our own static
1144                            version */
1145
1146                         static int nextid = 0;
1147                         char *nextidstr = Tcl_GetVar2(interp,"tcl::history","nextid",0);
1148                         if (nextidstr) {
1149                                 sscanf(nextidstr,"%d",&nextid);
1150                         }
1151                         print(interp,"dbg%d.%d> ",iPtr->numLevels,nextid++);
1152 #endif
1153                 } else {
1154                         print(interp,"dbg+> ");
1155                 }
1156                 fflush(stdout);
1157
1158                 if (0 >= (rc = read(0,line,BUFSIZ))) {
1159                         if (!newcmd) line[0] = 0;
1160                         else exit(0);
1161                 } else line[rc] = '\0';
1162
1163                 ccmd = Tcl_DStringAppend(&dstring,line,rc);
1164                 if (!Tcl_CommandComplete(ccmd)) {
1165                         newcmd = FALSE;
1166                         continue;       /* continue collecting command */
1167                 }
1168                 newcmd = TRUE;
1169
1170                 /* if user pressed return with no cmd, use previous one */
1171                 if ((ccmd[0] == '\n' || ccmd[0] == '\r') && ccmd[1] == '\0') {
1172
1173                         /* this loop is guaranteed to exit through break */
1174                         for (c = cmd_list;c->cmdname;c++) {
1175                                 if (c->cmdtype == last_action_cmd) break;
1176                         }
1177
1178                         /* recreate textual version of command */
1179                         Tcl_DStringAppend(&dstring,c->cmdname,-1);
1180
1181                         if (c->cmdtype == step ||
1182                             c->cmdtype == next ||
1183                             c->cmdtype == Next) {
1184                                 char num[10];
1185
1186                                 sprintf(num," %d",last_step_count);
1187                                 Tcl_DStringAppend(&dstring,num,-1);
1188                         }
1189                 }
1190
1191 #if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION < 4
1192                 rc = Tcl_RecordAndEval(interp,ccmd,0);
1193 #else
1194                 rc = Tcl_RecordAndEval(interp,ccmd,TCL_NO_EVAL);
1195                 rc = Tcl_Eval(interp,ccmd);
1196 #endif
1197                 Tcl_DStringFree(&dstring);
1198
1199                 switch (rc) {
1200                 case TCL_OK:
1201                         if (*interp->result != 0)
1202                                 print(interp,"%s\n",interp->result);
1203                         continue;
1204                 case TCL_ERROR:
1205                         print(interp,"%s\n",Tcl_GetVar(interp,"errorInfo",TCL_GLOBAL_ONLY));
1206                         /* since user is typing by hand, we expect lots
1207                            of errors, and want to give another chance */
1208                         continue;
1209                 case TCL_BREAK:
1210                 case TCL_CONTINUE:
1211 #define finish(x)       {rc = x; goto done;}
1212                         finish(rc);
1213                 case TCL_RETURN:
1214                         finish(TCL_OK);
1215                 default:
1216                         /* note that ccmd has trailing newline */
1217                         print(interp,"error %d: %s\n",rc,ccmd);
1218                         continue;
1219                 }
1220         }
1221         /* cannot fall thru here, must jump to label */
1222  done:
1223         Tcl_DStringFree(&dstring);
1224
1225         return(rc);
1226 }
1227
1228 static char init_auto_path[] = "lappend auto_path $dbg_library";
1229
1230 static void
1231 init_debugger(interp)
1232 Tcl_Interp *interp;
1233 {
1234         struct cmd_list *c;
1235
1236         for (c = cmd_list;c->cmdname;c++) {
1237                 Tcl_CreateCommand(interp,c->cmdname,c->cmdproc,
1238                         (ClientData)&c->cmdtype,(Tcl_CmdDeleteProc *)0);
1239         }
1240
1241         debug_handle = Tcl_CreateTrace(interp,
1242                                 10000,debugger_trap,(ClientData)0);
1243
1244         debugger_active = TRUE;
1245         Tcl_SetVar2(interp,Dbg_VarName,"active","1",0);
1246 #ifdef DBG_SCRIPTDIR
1247         Tcl_SetVar(interp,"dbg_library",DBG_SCRIPTDIR,0);
1248 #endif
1249         Tcl_Eval(interp,init_auto_path);
1250
1251 }
1252
1253 /* allows any other part of the application to jump to the debugger */
1254 /*ARGSUSED*/
1255 void
1256 Dbg_On(interp,immediate)
1257 Tcl_Interp *interp;
1258 int immediate;          /* if true, stop immediately */
1259                         /* should only be used in safe places */
1260                         /* i.e., when Tcl_Eval can be called */
1261 {
1262         if (!debugger_active) init_debugger(interp);
1263
1264         debug_cmd = step;
1265         step_count = 1;
1266
1267         if (immediate) {
1268                 static char *fake_cmd = "--interrupted-- (command_unknown)";
1269
1270                 debugger_trap((ClientData)0,interp,-1,fake_cmd,(int (*)())0,
1271                                         (ClientData)0,1,&fake_cmd);
1272 /*              (*interactor)(interp);*/
1273         }
1274 }
1275
1276 void
1277 Dbg_Off(interp)
1278 Tcl_Interp *interp;
1279 {
1280         struct cmd_list *c;
1281
1282         if (!debugger_active) return;
1283
1284         for (c = cmd_list;c->cmdname;c++) {
1285                 Tcl_DeleteCommand(interp,c->cmdname);
1286         }
1287
1288         Tcl_DeleteTrace(interp,debug_handle);
1289         debugger_active = FALSE;
1290         Tcl_UnsetVar(interp,Dbg_VarName,TCL_GLOBAL_ONLY);
1291 }