/* Dbg.c - Tcl Debugger - See cmdHelp() for commands

Written by: Don Libes, NIST, 3/23/93

Design and implementation of this program was paid for by U.S. tax
dollars.  Therefore it is public domain.  However, the author and NIST
would appreciate credit if this program or parts of it are used.

*/

#include <stdio.h>

#ifndef HAVE_STRCHR
#define strchr(s,c) index(s,c)
#endif /* HAVE_STRCHR */

#if 0
/* tclInt.h drags in stdlib.  By claiming no-stdlib, force it to drag in */
/* Tcl's compat version.  This avoids having to test for its presence */
/* which is too tricky - configure can't generate two cf files, so when */
/* Expect (or any app) uses the debugger, there's no way to get the info */
/* about whether stdlib exists or not, except pointing the debugger at */
/* an app-dependent .h file and I don't want to do that. */
#define NO_STDLIB_H
#endif


#include "tclInt.h"
/*#include <varargs.h>		tclInt.h drags in varargs.h.  Since Pyramid */
/*				objects to including varargs.h twice, just */
/*				omit this one. */
/*#include "string.h"		tclInt.h drags this in, too! */
#include "tcldbg.h"

#ifndef TRUE
#define TRUE 1
#define FALSE 0
#endif

static int simple_interactor (Tcl_Interp *interp, ClientData data);
static int zero (Tcl_Interp *interp, char *string);

/* most of the static variables in this file may be */
/* moved into Tcl_Interp */

static Dbg_InterProc *interactor = &simple_interactor;
static ClientData interdata = 0;
static Dbg_IgnoreFuncsProc *ignoreproc = &zero;
static Dbg_OutputProc *printproc = 0;
static ClientData printdata = 0;
static int stdinmode;

static void print _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));

static int debugger_active = FALSE;

/* this is not externally documented anywhere as of yet */
char *Dbg_VarName = "dbg";

#define DEFAULT_COMPRESS	0
static int compress = DEFAULT_COMPRESS;
#define DEFAULT_WIDTH		75	/* leave a little space for printing */
					/*  stack level */
static int buf_width = DEFAULT_WIDTH;

static int main_argc = 1;
static char *default_argv = "application";
static char **main_argv = &default_argv;

static Tcl_Trace debug_handle;
static int step_count = 1;	/* count next/step */

#define FRAMENAMELEN 10		/* enough to hold strings like "#4" */
static char viewFrameName[FRAMENAMELEN];/* destination frame name for up/down */

static CallFrame *goalFramePtr;	/* destination for next/return */
static int goalNumLevel;	/* destination for Next */

static enum debug_cmd {
	none, step, next, ret, cont, up, down, where, Next
} debug_cmd = step;

/* info about last action to use as a default */
static enum debug_cmd last_action_cmd = next;
static int last_step_count = 1;

/* this acts as a strobe (while testing breakpoints).  It is set to true */
/* every time a new debugger command is issued that is an action */
static int debug_new_action;

#define NO_LINE -1	/* if break point is not set by line number */

struct breakpoint {
	int id;
	Tcl_Obj *file;	/* file where breakpoint is */
	int line;	/* line where breakpoint is */
	int re;		/* 1 if this is regexp pattern */
	Tcl_Obj *pat;	/* pattern defining where breakpoint can be */
	Tcl_Obj *expr;	/* expr to trigger breakpoint */
	Tcl_Obj *cmd;	/* cmd to eval at breakpoint */
	struct breakpoint *next, *previous;
};

static struct breakpoint *break_base = 0;
static int breakpoint_max_id = 0;

static struct breakpoint *
breakpoint_new()
{
	struct breakpoint *b = (struct breakpoint *)ckalloc(sizeof(struct breakpoint));
	if (break_base) break_base->previous = b;
	b->next = break_base;
	b->previous = 0;
	b->id = breakpoint_max_id++;
	b->file = 0;
	b->line = NO_LINE;
	b->pat = 0;
	b->re = 0;
	b->expr = 0;
	b->cmd = 0;
	break_base = b;
	return(b);
}

static
void
breakpoint_print(interp,b)
Tcl_Interp *interp;
struct breakpoint *b;
{
    print(interp,"breakpoint %d: ",b->id);

    if (b->re) {
	print(interp,"-re \"%s\" ",Tcl_GetString(b->pat));
    } else if (b->pat) {
	print(interp,"-glob \"%s\" ",Tcl_GetString(b->pat));
    } else if (b->line != NO_LINE) {
	if (b->file) {
	    print(interp,"%s:",Tcl_GetString(b->file));
	}
	print(interp,"%d ",b->line);
    }

    if (b->expr)
	print(interp,"if {%s} ",Tcl_GetString(b->expr));

    if (b->cmd)
	print(interp,"then {%s}",Tcl_GetString(b->cmd));

    print(interp,"\n");
}

static void
save_re_matches(interp, re, objPtr)
Tcl_Interp *interp;
Tcl_RegExp re;
Tcl_Obj *objPtr;
{
    Tcl_RegExpInfo info;
    int i, start;
    char name[20];

    Tcl_RegExpGetInfo(re, &info); 
    for (i=0;i<=info.nsubs;i++) {
	start = info.matches[i].start;
	/* end = info.matches[i].end-1;*/

	if (start == -1) continue;

	sprintf(name,"%d",i);
	Tcl_SetVar2Ex(interp, Dbg_VarName, name, Tcl_GetRange(objPtr,
		info.matches[i].start, info.matches[i].end-1), 0);
    }
}

/* return 1 to break, 0 to continue */
static int
breakpoint_test(interp,cmd,bp)
Tcl_Interp *interp;
char *cmd;		/* command about to be executed */
struct breakpoint *bp;	/* breakpoint to test */
{
    if (bp->re) {
        int found = 0;
	Tcl_Obj *cmdObj;
	Tcl_RegExp re = Tcl_GetRegExpFromObj(NULL, bp->pat,
		TCL_REG_ADVANCED);
	cmdObj = Tcl_NewStringObj(cmd,-1);
	Tcl_IncrRefCount(cmdObj);
	if (Tcl_RegExpExecObj(NULL, re, cmdObj, 0 /* offset */,
		-1 /* nmatches */, 0 /* eflags */) > 0) {
	    save_re_matches(interp, re, cmdObj);
	    found = 1;
	}
	Tcl_DecrRefCount(cmdObj);
	if (!found) return 0;
    } else if (bp->pat) {
	if (0 == Tcl_StringMatch(cmd,
		Tcl_GetString(bp->pat))) return 0;
    } else if (bp->line != NO_LINE) {
	/* not yet implemented - awaiting support from Tcl */
	return 0;
    }

    if (bp->expr) {
	int value;

	/* ignore errors, since they are likely due to */
	/* simply being out of scope a lot */
	if (TCL_OK != Tcl_ExprBooleanObj(interp,bp->expr,&value)
		|| (value == 0)) return 0;
    }

    if (bp->cmd) {
	Tcl_EvalObjEx(interp, bp->cmd, 0);
    } else {
	breakpoint_print(interp,bp);
    }

    return 1;
}

static char *already_at_top_level = "already at top level";

/* similar to TclGetFrame but takes two frame ptrs and a direction.
If direction is up,   search up stack from curFrame
If direction is down, simulate searching down stack by
		      seaching up stack from origFrame
*/
static
int
TclGetFrame2(interp, origFramePtr, string, framePtrPtr, dir)
    Tcl_Interp *interp;
    CallFrame *origFramePtr;	/* frame that is true top-of-stack */
    char *string;		/* String describing frame. */
    CallFrame **framePtrPtr;	/* Store pointer to frame here (or NULL
				 * if global frame indicated). */
    enum debug_cmd dir;	/* look up or down the stack */
{
    Interp *iPtr = (Interp *) interp;
    int level, result;
    CallFrame *framePtr;	/* frame currently being searched */

    CallFrame *curFramePtr = iPtr->varFramePtr;

    /*
     * Parse string to figure out which level number to go to.
     */

    result = 1;
    if (*string == '#') {
	if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (level < 0) {
	    levelError:
	    Tcl_AppendResult(interp, "bad level \"", string, "\"",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	framePtr = origFramePtr; /* start search here */
	
    } else if (isdigit(*string)) {
	if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (dir == up) {
		if (curFramePtr == 0) {
			Tcl_SetResult(interp,already_at_top_level,TCL_STATIC);
			return TCL_ERROR;
		}
		level = curFramePtr->level - level;
		framePtr = curFramePtr; /* start search here */
	} else {
		if (curFramePtr != 0) {
			level = curFramePtr->level + level;
		}
		framePtr = origFramePtr; /* start search here */
	}
    } else {
	level = curFramePtr->level - 1;
	result = 0;
    }

    /*
     * Figure out which frame to use.
     */

    if (level == 0) {
	framePtr = NULL;
    } else {
	for (;framePtr != NULL;	framePtr = framePtr->callerVarPtr) {
	    if (framePtr->level == level) {
		break;
	    }
	}
	if (framePtr == NULL) {
	    goto levelError;
	}
    }
    *framePtrPtr = framePtr;
    return result;
}


static char *printify(s)
char *s;
{
    static int destlen = 0;
    char *d;		/* ptr into dest */
    unsigned int need;
    static char buf_basic[DEFAULT_WIDTH+1];
    static char *dest = buf_basic;
    Tcl_UniChar ch;

    if (s == 0) return("<null>");

    /* worst case is every character takes 4 to printify */
    need = strlen(s)*6;
    if (need > destlen) {
	if (dest && (dest != buf_basic)) ckfree(dest);
	dest = (char *)ckalloc(need+1);
	destlen = need;
    }

    for (d = dest;*s;) {
	s += Tcl_UtfToUniChar(s, &ch);
	if (ch == '\b') {
	    strcpy(d,"\\b");		d += 2;
	} else if (ch == '\f') {
	    strcpy(d,"\\f");		d += 2;
	} else if (ch == '\v') {
	    strcpy(d,"\\v");		d += 2;
	} else if (ch == '\r') {
	    strcpy(d,"\\r");		d += 2;
	} else if (ch == '\n') {
	    strcpy(d,"\\n");		d += 2;
	} else if (ch == '\t') {
	    strcpy(d,"\\t");		d += 2;
	} else if ((unsigned)ch < 0x20) { /* unsigned strips parity */
	    sprintf(d,"\\%03o",ch);		d += 4;
	} else if (ch == 0177) {
	    strcpy(d,"\\177");		d += 4;
	} else if ((ch < 0x80) && isprint(UCHAR(ch))) {
	    *d = (char)ch;		d += 1;
	} else {
	    sprintf(d,"\\u%04x",ch);	d += 6;
	}
    }
    *d = '\0';
    return(dest);
}

static
char *
print_argv(interp,argc,argv)
Tcl_Interp *interp;
int argc;
char *argv[];
{
	static int buf_width_max = DEFAULT_WIDTH;
	static char buf_basic[DEFAULT_WIDTH+1];	/* basic buffer */
	static char *buf = buf_basic;
	int space;		/* space remaining in buf */
	int len;
	char *bufp;
	int proc;		/* if current command is "proc" */
	int arg_index;

	if (buf_width > buf_width_max) {
		if (buf && (buf != buf_basic)) ckfree(buf);
		buf = (char *)ckalloc(buf_width + 1);
		buf_width_max = buf_width;
	}

	proc = (0 == strcmp("proc",argv[0]));
	sprintf(buf,"%.*s",buf_width,argv[0]);
	len = strlen(buf);
	space = buf_width - len;
	bufp = buf + len;
	argc--; argv++;
	arg_index = 1;
	
	while (argc && (space > 0)) {
		CONST char *elementPtr;
		CONST char *nextPtr;
		int wrap;

		/* braces/quotes have been stripped off arguments */
		/* so put them back.  We wrap everything except lists */
		/* with one argument.  One exception is to always wrap */
		/* proc's 2nd arg (the arg list), since people are */
		/* used to always seeing it this way. */

		if (proc && (arg_index > 1)) wrap = TRUE;
		else {
			(void) TclFindElement(interp,*argv,
#if TCL_MAJOR_VERSION >= 8
					      -1,
#endif
				&elementPtr,&nextPtr,(int *)0,(int *)0);
			if (*elementPtr == '\0') wrap = TRUE;
			else if (*nextPtr == '\0') wrap = FALSE;
			else wrap = TRUE;
		}

		/* wrap lists (or null) in braces */
		if (wrap) {
			sprintf(bufp," {%.*s}",space-3,*argv);
		} else {
			sprintf(bufp," %.*s",space-1,*argv);
		}
		len = strlen(buf);
		space = buf_width - len;
		bufp = buf + len;
		argc--; argv++;
		arg_index++;
	}

	if (compress) {
		/* this copies from our static buf to printify's static buf */
		/* and back to our static buf */
		strncpy(buf,printify(buf),buf_width);
	}

	/* usually but not always right, but assume truncation if buffer is */
	/* full.  this avoids tiny but odd-looking problem of appending "}" */
	/* to truncated lists during {}-wrapping earlier */
	if (strlen(buf) == buf_width) {
		buf[buf_width-1] = buf[buf_width-2] = buf[buf_width-3] = '.';
	}

	return(buf);
}

#if TCL_MAJOR_VERSION >= 8
static
char *
print_objv(interp,objc,objv)
Tcl_Interp *interp;
int objc;
Tcl_Obj *objv[];
{
    char **argv;
    int argc;
    int len;
    argv = (char **)ckalloc(objc+1 * sizeof(char *));
    for (argc=0 ; argc<objc ; argc++) {
	argv[argc] = Tcl_GetStringFromObj(objv[argc],&len);
    }
    argv[argc] = NULL;
    return(print_argv(interp,argc,argv));
}
#endif

static
void
PrintStackBelow(interp,curf,viewf)
Tcl_Interp *interp;
CallFrame *curf;	/* current FramePtr */
CallFrame *viewf;	/* view FramePtr */
{
	char ptr;	/* graphically indicate where we are in the stack */

	/* indicate where we are in the stack */
	ptr = ((curf == viewf)?'*':' ');

	if (curf == 0) {
		print(interp,"%c0: %s\n",
				ptr,print_argv(interp,main_argc,main_argv));
	} else {
		PrintStackBelow(interp,curf->callerVarPtr,viewf);
		print(interp,"%c%d: %s\n",ptr,curf->level,
#if TCL_MAJOR_VERSION >= 8
	      print_objv(interp,curf->objc,curf->objv)
#else
	      print_argv(interp,curf->argc,curf->argv)
#endif
	      );
	}
}

static
void
PrintStack(interp,curf,viewf,objc,objv,level)
Tcl_Interp *interp;
CallFrame *curf;	/* current FramePtr */
CallFrame *viewf;	/* view FramePtr */
     int objc;
     Tcl_Obj *CONST objv[];		/* Argument objects. */
char *level;
{
	PrintStackBelow(interp,curf,viewf);
    print(interp," %s: %s\n",level,print_objv(interp,objc,objv));
}

/* return 0 if goal matches current frame or goal can't be found */
/*	anywere in frame stack */
/* else return 1 */
/* This catches things like a proc called from a Tcl_Eval which in */
/* turn was not called from a proc but some builtin such as source */
/* or Tcl_Eval.  These builtin calls to Tcl_Eval lose any knowledge */
/* the FramePtr from the proc, so we have to search the entire */
/* stack frame to see if it's still there. */
static int
GoalFrame(goal,iptr)
CallFrame *goal;
Interp *iptr;
{
	CallFrame *cf = iptr->varFramePtr;

	/* if at current level, return success immediately */
	if (goal == cf) return 0;

	while (cf) {
		cf = cf->callerVarPtr;
		if (goal == cf) {
			/* found, but since it's above us, fail */
			return 1;
		}
	}
	return 0;
}

#if 0
static char *cmd_print(cmdtype)
enum debug_cmd cmdtype;
{
	switch (cmdtype) {
	case none:  return "cmd: none";
	case step:  return "cmd: step";
	case next:  return "cmd: next";
	case ret:   return "cmd: ret";
	case cont:  return "cmd: cont";
	case up:    return "cmd: up";
	case down:  return "cmd: down";
	case where: return "cmd: where";
	case Next:  return "cmd: Next";
	}
	return "cmd: Unknown";
}
#endif

/* debugger's trace handler */

static int
debugger_trap _ANSI_ARGS_ ((
     ClientData clientData,
     Tcl_Interp *interp,
     int level,
     CONST char *command,
     Tcl_Command commandInfo,
     int objc,
     struct Tcl_Obj * CONST * objv));


/*ARGSUSED*/
static int
debugger_trap(clientData,interp,level,command,commandInfo,objc,objv)
     ClientData clientData;		/* not used */
     Tcl_Interp *interp;
     int level;			/* positive number if called by Tcl, -1 if */
				/* called by Dbg_On in which case we don't */
				/* know the level */
     CONST char *command;
     Tcl_Command commandInfo; /* Unused */
     int objc;
     struct Tcl_Obj * CONST * objv;
{
	char level_text[6];	/* textual representation of level */

	int break_status;
	Interp *iPtr = (Interp *)interp;

	CallFrame *trueFramePtr;	/* where the pc is */
	CallFrame *viewFramePtr;	/* where up/down are */

	int print_command_first_time = TRUE;
	static int debug_suspended = FALSE;

	struct breakpoint *b;

    char* thecmd;

	/* skip commands that are invoked interactively */
    if (debug_suspended) return TCL_OK;

    thecmd = Tcl_GetString (objv[0]);
	/* skip debugger commands */
    if (thecmd[1] == '\0') {
	switch (thecmd[0]) {
		case 'n':
		case 's':
		case 'c':
		case 'r':
		case 'w':
		case 'b':
		case 'u':
	case 'd': return TCL_OK;
		}
	}

    if ((*ignoreproc)(interp,thecmd)) return TCL_OK;

	/* if level is unknown, use "?" */
	sprintf(level_text,(level == -1)?"?":"%d",level);

	/* save so we can restore later */
	trueFramePtr = iPtr->varFramePtr;

	/* do not allow breaking while testing breakpoints */
	debug_suspended = TRUE;

	/* test all breakpoints to see if we should break */
	/* if any successful breakpoints, start interactor */
	debug_new_action = FALSE;	/* reset strobe */
	break_status = FALSE;		/* no successful breakpoints yet */
	for (b = break_base;b;b=b->next) {
		break_status |= breakpoint_test(interp,command,b);
	}
	if (break_status) {
		if (!debug_new_action) {
			goto start_interact;
		}

		/* if s or n triggered by breakpoint, make "s 1" */
		/* (and so on) refer to next command, not this one */
		/* step_count++;*/
		goto end_interact;
	}

	switch (debug_cmd) {
	case cont:
		goto finish;
	case step:
		step_count--;
		if (step_count > 0) goto finish;
		goto start_interact;
	case next:
		/* check if we are back at the same level where the next */
		/* command was issued.  Also test */
		/* against all FramePtrs and if no match, assume that */
		/* we've missed a return, and so we should break  */
/*		if (goalFramePtr != iPtr->varFramePtr) goto finish;*/
		if (GoalFrame(goalFramePtr,iPtr)) goto finish;
		step_count--;
		if (step_count > 0) goto finish;
		goto start_interact;
	case Next:
		/* check if we are back at the same level where the next */
		/* command was issued.  */
		if (goalNumLevel < iPtr->numLevels) goto finish;
		step_count--;
		if (step_count > 0) goto finish;
		goto start_interact;
	case ret:
		/* same comment as in "case next" */
		if (goalFramePtr != iPtr->varFramePtr) goto finish;
		goto start_interact;
    /* DANGER: unhandled cases! none, up, down, where */
	}

start_interact:
	if (print_command_first_time) {
		print(interp,"%s: %s\n",
				level_text,print_argv(interp,1,&command));
		print_command_first_time = FALSE;
	}
	/* since user is typing a command, don't interrupt it immediately */
	debug_cmd = cont;
	debug_suspended = TRUE;

	/* interactor won't return until user gives a debugger cmd */
	(*interactor)(interp,interdata);
end_interact:

	/* save this so it can be restored after "w" command */
	viewFramePtr = iPtr->varFramePtr;

	if (debug_cmd == up || debug_cmd == down) {
		/* calculate new frame */
		if (-1 == TclGetFrame2(interp,trueFramePtr,viewFrameName,
					&iPtr->varFramePtr,debug_cmd)) {
	    print(interp,"%s\n",Tcl_GetStringResult (interp));
			Tcl_ResetResult(interp);
		}
		goto start_interact;
	}

	/* reset view back to normal */
	iPtr->varFramePtr = trueFramePtr;

#if 0
	/* allow trapping */
	debug_suspended = FALSE;
#endif

	switch (debug_cmd) {
	case cont:
	case step:
		goto finish;
	case next:
		goalFramePtr = iPtr->varFramePtr;
		goto finish;
	case Next:
		goalNumLevel = iPtr->numLevels;
		goto finish;
	case ret:
		goalFramePtr = iPtr->varFramePtr;
		if (goalFramePtr == 0) {
			print(interp,"nowhere to return to\n");
			break;
		}
		goalFramePtr = goalFramePtr->callerVarPtr;
		goto finish;
	case where:
	PrintStack(interp,iPtr->varFramePtr,viewFramePtr,objc,objv,level_text);
		break;
	}

	/* restore view and restart interactor */
	iPtr->varFramePtr = viewFramePtr;
	goto start_interact;

 finish:
	debug_suspended = FALSE;
	return TCL_OK;
}

/*ARGSUSED*/
static
int
cmdNext(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];		/* Argument objects. */
{
	debug_new_action = TRUE;
	debug_cmd = *(enum debug_cmd *)clientData;

	last_action_cmd = debug_cmd;

    if (objc == 1) {
	step_count = 1;
    } else if (TCL_OK != Tcl_GetIntFromObj (interp, objv[1], &step_count)) {
	return TCL_ERROR;
    }

	last_step_count = step_count;
	return(TCL_RETURN);
}

/*ARGSUSED*/
static
int
cmdDir(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    char* frame;
    debug_cmd = *(enum debug_cmd *)clientData;

    if (objc == 1) {
	frame = "1";
    } else {
	frame = Tcl_GetString (objv[1]);
    }

    strncpy(viewFrameName,frame,FRAMENAMELEN);
	return TCL_RETURN;
}

/*ARGSUSED*/
static
int
cmdSimple(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];		/* Argument objects. */
{
	debug_new_action = TRUE;
	debug_cmd = *(enum debug_cmd *)clientData;
	last_action_cmd = debug_cmd;

	return TCL_RETURN;
}

static
void
breakpoint_destroy(b)
struct breakpoint *b;
{
	if (b->file) Tcl_DecrRefCount(b->file);
	if (b->pat) Tcl_DecrRefCount(b->pat);
	if (b->cmd) Tcl_DecrRefCount(b->cmd);
	if (b->expr) Tcl_DecrRefCount(b->expr);

	/* unlink from chain */
	if ((b->previous == 0) && (b->next == 0)) {
		break_base = 0;
	} else if (b->previous == 0) {
		break_base = b->next;
		b->next->previous = 0;
	} else if (b->next == 0) {
		b->previous->next = 0;
	} else {
		b->previous->next = b->next;
		b->next->previous = b->previous;
	}

	ckfree((char *)b);
}

static void
savestr(objPtr,str)
Tcl_Obj **objPtr;
char *str;
{
    *objPtr = Tcl_NewStringObj(str, -1);
    Tcl_IncrRefCount(*objPtr);
}

/*ARGSUSED*/
static
int
cmdWhere(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    static char* options [] = {
	"-compress",
	"-width",
	NULL
    };
    enum options {
	WHERE_COMPRESS,
	WHERE_WIDTH
    };
    int i;

    if (objc == 1) {
		debug_cmd = where;
		return TCL_RETURN;
	}

    /* Check and process switches */

    for (i=1; i<objc; i++) {
	char *name;
	int index;

	name = Tcl_GetString(objv[i]);
	if (name[0] != '-') {
	    break;
		}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
				&index) != TCL_OK) {
	    goto usage;
	}
	switch ((enum options) index) {
	case WHERE_COMPRESS:
	    i++;
	    if (i >= objc) {
		print(interp,"%d\n",compress);
		break;
	    }
	    if (TCL_OK != Tcl_GetBooleanFromObj (interp, objv[i], &buf_width))
		goto usage;
	    break;
	case WHERE_WIDTH:
	    i++;
	    if (i >= objc) {
		print(interp,"%d\n",buf_width);
		break;
	}
	    if (TCL_OK != Tcl_GetIntFromObj (interp, objv[i], &buf_width))
		goto usage;
	    break;
	}
    }

    if (i < objc) goto usage;

	return TCL_OK;

 usage:
    print(interp,"usage: w [-width #] [-compress 0|1]\n");
    return TCL_ERROR;
}

#define breakpoint_fail(msg) {error_msg = msg; goto break_fail;}

/*ARGSUSED*/
static
int
cmdBreak(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];		/* Argument objects. */
{
	struct breakpoint *b;
	char *error_msg;

    static char* options [] = {
	"-glob",
	"-regexp",
	"if",
	"then",
	NULL
    };
    enum options {
	BREAK_GLOB,
	BREAK_RE,
	BREAK_IF,
	BREAK_THEN
    };
    int i;
    int index;


    /* No arguments, list breakpoints */
    if (objc == 1) {
		for (b = break_base;b;b=b->next) breakpoint_print(interp,b);
		return(TCL_OK);
	}

    /* Process breakpoint deletion (-, -x) */

    /* Copied from exp_prog.h */
#define streq(x,y)	(0 == strcmp((x),(y)))

    if (objc == 2) {
	int id;

	if (streq (Tcl_GetString (objv[1]),"-")) {
			while (break_base) {
				breakpoint_destroy(break_base);
			}
			breakpoint_max_id = 0;
			return(TCL_OK);
	}

	if ((Tcl_GetString (objv[1])[0] == '-') &&
	    (TCL_OK == Tcl_GetIntFromObj (interp, objv[1], &id))) {
	    id = -id;

			for (b = break_base;b;b=b->next) {
				if (b->id == id) {
					breakpoint_destroy(b);
					if (!break_base) breakpoint_max_id = 0;
					return(TCL_OK);
				}
			}
			Tcl_SetResult(interp,"no such breakpoint",TCL_STATIC);
			return(TCL_ERROR);
		}
	}

	b = breakpoint_new();

    /* Process switches */

    i = 1;
    if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
			    &index) == TCL_OK) {
	switch ((enum options) index) {
	case BREAK_GLOB:
	    i++;
	    if (i == objc) breakpoint_fail("no pattern?");
	    savestr(&b->pat,Tcl_GetString (objv[i]));
	    i++;
	    break;
	case BREAK_RE:
	    i++;
	    if (i == objc) breakpoint_fail("bad regular expression");
		    b->re = 1;
	    savestr(&b->pat,Tcl_GetString (objv[i]));
	    if (Tcl_GetRegExpFromObj(interp, b->pat, TCL_REG_ADVANCED) == NULL) {
			breakpoint_destroy(b);
			return TCL_ERROR;
		    }
	    i++;
	    break;
	case BREAK_IF:   break;
	case BREAK_THEN: break;
		}
		} else {
		/* look for [file:]line */
		char *colon;
		char *linep;	/* pointer to beginning of line number */
	char* ref = Tcl_GetString (objv[i]);
	colon = strchr(ref,':');
		if (colon) {
			*colon = '\0';
	    savestr(&b->file,ref);
			*colon = ':';
			linep = colon + 1;
		} else {
	    linep = ref;
			/* get file from current scope */
			/* savestr(&b->file, ?); */
		}

		if (TCL_OK == Tcl_GetInt(interp,linep,&b->line)) {
	    i++;
			print(interp,"setting breakpoints by line number is currently unimplemented - use patterns or expressions\n");
		} else {
			/* not an int? - unwind & assume it is an expression */

			if (b->file) Tcl_DecrRefCount(b->file);
		}

	}

    if (i < objc) {
		int do_if = FALSE;

	if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
				&index) == TCL_OK) {
	    switch ((enum options) index) {
	    case BREAK_IF:
		i++;
		do_if = TRUE;
		/* Consider next word as expression */
		break;
	    case BREAK_THEN:
		/* No 'if expression' guard here, do nothing */
		break;
	    case BREAK_GLOB:
	    case BREAK_RE:
			do_if = TRUE;
		/* Consider current word as expression, without a preceding 'if' */
		break;
	    }
	} else {
	    /* Consider current word as expression, without a preceding 'if' */
			do_if = TRUE;
		}

		if (do_if) {
	    if (i == objc) breakpoint_fail("if what");
	    savestr(&b->expr,Tcl_GetString (objv[i]));
	    i++;
		}
	}

    if (i < objc) {
	/* Remainder is a command */
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "flag", 0,
				&index) == TCL_OK) {
	    switch ((enum options) index) {
	    case BREAK_THEN:
		i++;
		break;
	    case BREAK_IF:
	    case BREAK_GLOB:
	    case BREAK_RE:
		break;
		}
		}

	if (i == objc) breakpoint_fail("then what?");

	savestr(&b->cmd,Tcl_GetString (objv[i]));
	}

    Tcl_SetObjResult (interp, Tcl_NewIntObj (b->id));
	return(TCL_OK);

 break_fail:
	breakpoint_destroy(b);
	Tcl_SetResult(interp,error_msg,TCL_STATIC);
	return(TCL_ERROR);
}

static char *help[] = {
"s [#]		step into procedure",
"n [#]		step over procedure",
"N [#]		step over procedures, commands, and arguments",
"c		continue",
"r		continue until return to caller",
"u [#]		move scope up level",
"d [#]		move scope down level",
"		go to absolute frame if # is prefaced by \"#\"",
"w		show stack (\"where\")",
"w -w [#]	show/set width",
"w -c [0|1]	show/set compress",
"b		show breakpoints",
"b [-r regexp-pattern] [if expr] [then command]",
"b [-g glob-pattern]   [if expr] [then command]",
"b [[file:]#]          [if expr] [then command]",
"		if pattern given, break if command resembles pattern",
"		if # given, break on line #",
"		if expr given, break if expr true",
"		if command given, execute command at breakpoint",
"b -#		delete breakpoint",
"b -		delete all breakpoints",
0};

/*ARGSUSED*/
static
int
cmdHelp(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];		/* Argument objects. */
{
	char **hp;

	for (hp=help;*hp;hp++) {
		print(interp,"%s\n",*hp);
	}

	return(TCL_OK);
}

/* occasionally, we print things larger buf_max but not by much */
/* see print statements in PrintStack routines for examples */
#define PAD 80

/*VARARGS*/
static void
print TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
	Tcl_Interp *interp;
	char *fmt;
	va_list args;

	interp = TCL_VARARGS_START(Tcl_Interp *,arg1,args);
	fmt = va_arg(args,char *);
	if (!printproc) vprintf(fmt,args);
	else {
		static int buf_width_max = DEFAULT_WIDTH+PAD;
		static char buf_basic[DEFAULT_WIDTH+PAD+1];
		static char *buf = buf_basic;

		if (buf_width+PAD > buf_width_max) {
			if (buf && (buf != buf_basic)) ckfree(buf);
			buf = (char *)ckalloc(buf_width+PAD+1);
			buf_width_max = buf_width+PAD;
		}

		vsprintf(buf,fmt,args);
		(*printproc)(interp,buf,printdata);
	}
	va_end(args);
}

/*ARGSUSED*/
Dbg_InterStruct
Dbg_Interactor(interp,inter_proc,data)
Tcl_Interp *interp;
Dbg_InterProc *inter_proc;
ClientData data;
{
	Dbg_InterStruct tmp;

	tmp.func = interactor;
	tmp.data = interdata;
	interactor = (inter_proc?inter_proc:simple_interactor);
	interdata = data;
	return tmp;
}

/*ARGSUSED*/
Dbg_IgnoreFuncsProc *
Dbg_IgnoreFuncs(interp,proc)
Tcl_Interp *interp;
Dbg_IgnoreFuncsProc *proc;
{
	Dbg_IgnoreFuncsProc *tmp = ignoreproc;
	ignoreproc = (proc?proc:zero);
	return tmp;
}

/*ARGSUSED*/
Dbg_OutputStruct
Dbg_Output(interp,proc,data)
Tcl_Interp *interp;
Dbg_OutputProc *proc;
ClientData data;
{
	Dbg_OutputStruct tmp;

	tmp.func = printproc;
	tmp.data = printdata;
	printproc = proc;
	printdata = data;
	return tmp;
}

/*ARGSUSED*/
int
Dbg_Active(interp)
Tcl_Interp *interp;
{
	return debugger_active;
}

char **
Dbg_ArgcArgv(argc,argv,copy)
int argc;
char *argv[];
int copy;
{
	char **alloc;

	main_argc = argc;

	if (!copy) {
		main_argv = argv;
		alloc = 0;
	} else {
		main_argv = alloc = (char **)ckalloc((argc+1)*sizeof(char *));
		while (argc-- >= 0) {
			*main_argv++ = *argv++;
		}
		main_argv = alloc;
	}
	return alloc;
}

static struct cmd_list {
	char *cmdname;
    Tcl_ObjCmdProc *cmdproc;
	enum debug_cmd cmdtype;
} cmd_list[]  = {
		{"n", cmdNext,   next},
		{"s", cmdNext,   step},
		{"N", cmdNext,   Next},
		{"c", cmdSimple, cont},
		{"r", cmdSimple, ret},
		{"w", cmdWhere,  none},
		{"b", cmdBreak,  none},
		{"u", cmdDir,    up},
		{"d", cmdDir,    down},
		{"h", cmdHelp,   none},
		{0}
};

/* this may seem excessive, but this avoids the explicit test for non-zero */
/* in the caller, and chances are that that test will always be pointless */
/*ARGSUSED*/
static int
zero (Tcl_Interp *interp, char *string)
{
	return 0;
}

extern int expSetBlockModeProc _ANSI_ARGS_((int fd, int mode));

static int
simple_interactor(Tcl_Interp *interp, ClientData data)
{
	int rc;
	char *ccmd;		/* pointer to complete command */
	char line[BUFSIZ+1];	/* space for partial command */
	int newcmd = TRUE;
	Interp *iPtr = (Interp *)interp;

	Tcl_DString dstring;
	Tcl_DStringInit(&dstring);

	/* Force blocking if necessary */

	if (stdinmode == TCL_MODE_NONBLOCKING) {
	  expSetBlockModeProc(0, TCL_MODE_BLOCKING);
	}

	newcmd = TRUE;
	while (TRUE) {
		struct cmd_list *c;

		if (newcmd) {
#if TCL_MAJOR_VERSION < 8
			print(interp,"dbg%d.%d> ",iPtr->numLevels,iPtr->curEventNum+1);
#else
			/* unncessarily tricky coding - if nextid
			   isn't defined, maintain our own static
			   version */

			static int nextid = 0;
			CONST char *nextidstr = Tcl_GetVar2(interp,"tcl::history","nextid",0);
			if (nextidstr) {
				sscanf(nextidstr,"%d",&nextid);
			}
			print(interp,"dbg%d.%d> ",iPtr->numLevels,nextid++);
#endif
		} else {
			print(interp,"dbg+> ");
		}
		fflush(stdout);

		rc = read(0,line,BUFSIZ);
		if (0 >= rc) {
			if (!newcmd) line[0] = 0;
			else exit(0);
		} else line[rc] = '\0';

		ccmd = Tcl_DStringAppend(&dstring,line,rc);
		if (!Tcl_CommandComplete(ccmd)) {
			newcmd = FALSE;
			continue;	/* continue collecting command */
		}
		newcmd = TRUE;

		/* if user pressed return with no cmd, use previous one */
		if ((ccmd[0] == '\n' || ccmd[0] == '\r') && ccmd[1] == '\0') {

			/* this loop is guaranteed to exit through break */
			for (c = cmd_list;c->cmdname;c++) {
				if (c->cmdtype == last_action_cmd) break;
			}

			/* recreate textual version of command */
			Tcl_DStringAppend(&dstring,c->cmdname,-1);

			if (c->cmdtype == step ||
			    c->cmdtype == next ||
			    c->cmdtype == Next) {
				char num[10];

				sprintf(num," %d",last_step_count);
				Tcl_DStringAppend(&dstring,num,-1);
			}
		}

#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION < 4
		rc = Tcl_RecordAndEval(interp,ccmd,0);
#else
		rc = Tcl_RecordAndEval(interp,ccmd,TCL_NO_EVAL);
		rc = Tcl_Eval(interp,ccmd);
#endif
		Tcl_DStringFree(&dstring);

		switch (rc) {
		case TCL_OK:
	    {
		char* res = Tcl_GetStringResult (interp);
		if (*res != 0)
		    print(interp,"%s\n",res);
	    }
			continue;
		case TCL_ERROR:
			print(interp,"%s\n",Tcl_GetVar(interp,"errorInfo",TCL_GLOBAL_ONLY));
			/* since user is typing by hand, we expect lots
			   of errors, and want to give another chance */
			continue;
		case TCL_BREAK:
		case TCL_CONTINUE:
#define finish(x)	{rc = x; goto done;}
			finish(rc);
		case TCL_RETURN:
			finish(TCL_OK);
		default:
			/* note that ccmd has trailing newline */
			print(interp,"error %d: %s\n",rc,ccmd);
			continue;
		}
	}
	/* cannot fall thru here, must jump to label */
 done:
	Tcl_DStringFree(&dstring);

	/* Restore old blocking mode */
	if (stdinmode == TCL_MODE_NONBLOCKING) {
	  expSetBlockModeProc(0, TCL_MODE_NONBLOCKING);
	}
	return(rc);
}

static char init_auto_path[] = "lappend auto_path $dbg_library";

static void
init_debugger(interp)
Tcl_Interp *interp;
{
	struct cmd_list *c;

	for (c = cmd_list;c->cmdname;c++) {
	Tcl_CreateObjCommand(interp,c->cmdname,c->cmdproc,
			(ClientData)&c->cmdtype,(Tcl_CmdDeleteProc *)0);
	}

    debug_handle = Tcl_CreateObjTrace(interp,10000,0,
				      debugger_trap,(ClientData)0, NULL);

	debugger_active = TRUE;
	Tcl_SetVar2(interp,Dbg_VarName,"active","1",0);
#ifdef DBG_SCRIPTDIR
	Tcl_SetVar(interp,"dbg_library",DBG_SCRIPTDIR,0);
#endif
	Tcl_Eval(interp,init_auto_path);

}

/* allows any other part of the application to jump to the debugger */
/*ARGSUSED*/
void
Dbg_On(interp,immediate)
Tcl_Interp *interp;
int immediate;		/* if true, stop immediately */
			/* should only be used in safe places */
			/* i.e., when Tcl_Eval can be called */
{
	if (!debugger_active) init_debugger(interp);

	/* Initialize debugger in single-step mode.  Note: if the
	  command reader is already active, it's too late which is why
	  we also statically initialize debug_cmd to step. */
	debug_cmd = step;
	step_count = 1;

#define LITERAL(s) Tcl_NewStringObj ((s), sizeof(s)-1)

	if (immediate) {
	Tcl_Obj* fake_cmd = LITERAL ( "--interrupted-- (command_unknown)");

	Tcl_IncrRefCount (fake_cmd);
	debugger_trap((ClientData)0,interp,-1,Tcl_GetString (fake_cmd),0,1,&fake_cmd);
/*		(*interactor)(interp);*/
	Tcl_DecrRefCount (fake_cmd);
	}
}

void
Dbg_Off(interp)
Tcl_Interp *interp;
{
	struct cmd_list *c;

	if (!debugger_active) return;

	for (c = cmd_list;c->cmdname;c++) {
		Tcl_DeleteCommand(interp,c->cmdname);
	}

	Tcl_DeleteTrace(interp,debug_handle);
	debugger_active = FALSE;
	Tcl_UnsetVar(interp,Dbg_VarName,TCL_GLOBAL_ONLY);

	/* initialize for next use */
	debug_cmd = step;
	step_count = 1;
}

/* allows any other part of the application to tell the debugger where the Tcl channel for stdin is. */
/*ARGSUSED*/
void
Dbg_StdinMode(mode)
     int mode;
{
  stdinmode = mode;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */