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