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