/* Copyright(c) 1993 Association of Universities for Research in Astronomy Inc.
 */

#include <ObmP.h>
#include "widget.h"

/*
 * HTML widget class (a subclass of Widget).
 * -------------------------------------------------------------------------
 * The HTML (hypertext markup language) widget displays a block of HTML
 * formatted text, the "document" to be displayed.  The text consists of a
 * mixture of text to be displayed and embedded formatting directives.  The
 * text may also contain "hot links" pointing to other HTML-formatted
 * documents.
 *
 *  	        setText text [target [header_text [footer_text]]]
 *       text = getText [format [font]]
 *	  retestAnchors
 *
 *    id = positionToId x y
 *         idToPosition id x y
 *     anchorToPosition name x y
 *      id = anchorToId name
 *		 gotoId id
 *
 *         n = getHRefs list
 *     n = getImageSrcs list
 *         n = getLinks list
 *
 *         setSelection start end
 *  text = getSelection start end
 *	 clearSelection
 *
 * 	     searchText pattern start end [direction [search_type]]
 *
 * 	    addCallback procedure-name [callback-type]
 * 	 deleteCallback procedure-name [callback-type]
 *
 * The possible callback types and their callback arguments are as follows.
 * 
 *	anchor		widget cbtype event text href element_id
 *	testAnchor	widget cbtype href
 *	submitForm	widget cbtype event attrs href method enctype encentity
 *	link		widget cbtype href role
 *	pointerMotion	widget cbtype href
 *
 * See the comments below for further details on the callback types and their
 * arguments.
 *
 * All a "hot link" is to the HTML widget is a document object containing a
 * HREF which causes a callback when selected by the user viewing the document.
 * It is up to the application using the HTML widget to define what the meaning 
 * of an HREF is.
 *
 * This version of the HTML widget binding does not yet support inline images.
 */

#define	CB_Anchor		1
#define	CB_TestAnchor		2
#define	CB_PointerMotion	3
#define	CB_SubmitForm		4
#define	CB_Link			5

/* HTML class instance descriptor. */
struct htmlPrivate {
	ObmCallback callback_list;
};

typedef struct htmlPrivate *HTMLPrivate;

struct htmlObject {
	struct obmObjectCore core;
	struct widgetPrivate widget;
	struct htmlPrivate html;
};

typedef struct htmlObject *HTMLObject;

/* HTML class class record private data. */
typedef struct {
	/* standard MsgContext fields. */
	Tcl_Interp *tcl;                /* class interpreter */
	ObmObject object[MAX_LEVELS];   /* object which received last message */
	int level;

	/* HTML specific fields. */
	/* (none) */
} htmlClassData, *HTMLClassData;


void HTMLDestroy();
void HTMLClassDestroy();
ObmObject HTMLCreate();

static int htmlSetText(), htmlGetText(), htmlGetHRefs();
static int htmlGetImageSrcs(), htmlGetLinks();
static int htmlRetestAnchors(), htmlPositionToId(), htmlIdToPosition();
static int htmlAnchorToPosition(), htmlAnchorToId();
static int htmlGotoId(), htmlAddCallback(), htmlDeleteCallback();
static int htmlSetSelection(), htmlGetSelection(), htmlClearSelection();
static int htmlSearchText();

static void anchorCallback(), pointerMotionCallback();
static void submitFormCallback(), linkCallback();
static char *cb_encode(), *makeList();
static int testAnchorCallback();
static void cb_error();
static int cb_decode();
extern long strtol();


/* HTMLClassInit -- Initialize the class record for the HTML widget class.
 */
void
HTMLClassInit (obm, classrec)
ObmContext obm;
register ObjClassRec classrec;
{
	register HTMLClassData gcd;
	register Tcl_Interp *tcl;
	register ClientData c_gcd;

	/* Install the class methods. */
	classrec->ClassDestroy = HTMLClassDestroy;
	classrec->Create = (ObmFunc) HTMLCreate;
	classrec->Destroy = HTMLDestroy;
	classrec->Evaluate = WidgetEvaluate;

	/* The HTML widget subclass has its own command set hence has its
	 * own interpreter.  The widget will respond both to all the commands
	 * defined here, and to all the commands implemented by the base
	 * Widget class.
	 */
	if (!classrec->class_data) {
	    gcd = (HTMLClassData) XtCalloc (1, sizeof (htmlClassData));
	    gcd->tcl = tcl = Tcl_CreateInterp();
	    classrec->class_data = (XtPointer) gcd;
	    c_gcd = (ClientData)gcd;
	    gcd->level = 0;

	    Tcl_CreateCommand (tcl,
		"addCallback", htmlAddCallback, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"deleteCallback", htmlDeleteCallback, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"setText", htmlSetText, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"getText", htmlGetText, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"positionToId", htmlPositionToId, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"idToPosition", htmlIdToPosition, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"anchorToPosition", htmlAnchorToPosition, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"anchorToId", htmlAnchorToId, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"gotoId", htmlGotoId, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"getHRefs", htmlGetHRefs, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"getImageSrcs", htmlGetImageSrcs, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"getLinks", htmlGetLinks, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"retestAnchors", htmlRetestAnchors, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"setSelection", htmlSetSelection, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"getSelection", htmlGetSelection, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"clearSelection", htmlClearSelection, c_gcd, NULL);
	    Tcl_CreateCommand (tcl,
		"searchText", htmlSearchText, c_gcd, NULL);
	}
}


/* HTMLClassDestroy -- Custom destroy procedure for the HTML class.
 */
void
HTMLClassDestroy (obm, classrec)
ObmContext obm;
register ObjClassRec classrec;
{
	register HTMLClassData gcd = (HTMLClassData) classrec->class_data;

	if (gcd) {
	    if (gcd->tcl)
		Tcl_DeleteInterp (gcd->tcl);
	    XtFree ((char *)gcd);
	    classrec->class_data = NULL;
	}
}


/* HTMLCreate -- Create an instance of a HTML object.
 */
ObmObject
HTMLCreate (obm, name, classrec, parent, a_args, a_nargs)
ObmContext obm;
char *name;
ObjClassRec classrec;
char *parent;
ArgList a_args;
int a_nargs;
{
	register HTMLObject obj;
	register Widget w;
	Arg args[128];
	int nargs = 0;

	for (nargs = 0;  nargs < a_nargs;  nargs++)
	    args[nargs] = a_args[nargs];

	XtSetArg (args[nargs], WbNpreviouslyVisitedTestFunction,
	    (long)testAnchorCallback);		nargs++;
	XtSetArg (args[nargs], WbNpointerMotionCallback,
	    (long)pointerMotionCallback);	nargs++;

	obj = (HTMLObject) WidgetCreate (obm, name,classrec,parent,args,nargs);
	if (obj == NULL)
	    return (NULL);
	obj = (HTMLObject) XtRealloc ((char *)obj, sizeof(struct htmlObject));
	if (obj == NULL)
	    return (NULL);

	w = obj->widget.w;
	/* register_image_resolution_function (w); */
	XtAddCallback (w, WbNanchorCallback, anchorCallback, (XtPointer)obj);
	XtAddCallback (w, WbNlinkCallback, linkCallback, (XtPointer)obj);
	XtAddCallback (w, WbNsubmitFormCallback, submitFormCallback,
	    (XtPointer)obj);

	XtSetArg (args[0], WbNpreviouslyVisitedTestData, obj);
	XtSetArg (args[1], WbNpointerMotionData, obj);
	XtSetValues (w, args, 2);

	/* Initialize HTMLPrivate instance structure. */
	obj->html.callback_list = NULL;

	return ((ObmObject) obj);
}


/* HTMLDestroy -- Destroy an instance of a HTML object.
 */
void
HTMLDestroy (object)
ObmObject object;
{
	HTMLObject obj = (HTMLObject) object;
	ObjClassRec classrec = obj->core.classrec;
	register HTMLClassData gcd = (HTMLClassData) classrec->class_data;
	register ObmCallback cb, cb_next;
	ObmContext obm = obj->widget.obm;
	Widget w = obj->widget.w;

	/* Destroy the object in the second final call to Destroy. */
	if (!obj->core.being_destroyed++)
	    return;

	/* Free any HTML callback descriptors. */
	for (cb = obj->html.callback_list;  cb;  cb = cb_next) {
	    cb_next = cb->next;

	    XtFree ((char *)cb);
	}

	WidgetDestroy (object);
}


/*
 * HTML class functions.
 * -----------------------
 */


/* setText -- Set the text to be displayed in the HTML widget.
 *
 *  Usage:	setText text [target [header_text [footer_text]]]
 *
 * If a target anchor is given the text will be positioned to view the
 * given anchor.  The target anchor may be specified either by name or by
 * its element_id (tag number within the document, e.g. as returned in the
 * anchor callback).  If any HTML-formatted header or footer text is given
 * this will be displayed before or after the document passed in as "text".
 */
static int 
htmlSetText (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	ObmContext obm = wp->obm;
	char *text, *target_anchor;
	char *header_text, *footer_text;
	int element_id;

	text = (argc > 1) ? argv[1] : NULL;
	target_anchor = (argc > 2) ? argv[2] : NULL;
	header_text = (argc > 3) ? argv[3] : NULL;
	footer_text = (argc > 4) ? argv[4] : NULL;
	element_id = target_anchor ? atoi (target_anchor) : 0;

	HTMLSetText (wp->w, text,
	    header_text, footer_text, element_id, target_anchor, NULL);

	return (TCL_OK);
}


/* getText -- Get the text of the document currently being displayed.
 *
 *  Usage:	text = getText [format [font]]
 *
 * The optional format argument determines the type of text to be returned.
 * The possible values are as follows.
 *
 *	simple		No formatting other than indents.
 *	pretty		Simple formatting.
 *	postscript	Return formatted Postscript.	
 *
 * The default output format is simple.  If Postscript output is selected
 * the font can be selected from one of the following:
 *
 *	times		Times
 *	helvetica	Helvetica
 *	schoolbook	New century schoolbook
 *	lucida		Lucida Bright
 *
 * The default Postscript font is Times.
 */
static int 
htmlGetText (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	char *text, *format, *font;
	int pretty = 0;

	format = (argc > 1) ? argv[1] : "simple";
	font   = (argc > 2) ? argv[2] : "times";

	if (strcmp (format, "simple") == 0)
	    pretty = 0;
	else if (strcmp (format, "pretty") == 0)
	    pretty = 1;
	else if (strcmp (format, "postscript") == 0) {
	    if (strcmp (font, "times") == 0)
		pretty = 2;
	    else if (strcmp (font, "helvetica") == 0)
		pretty = 3;
	    else if (strcmp (font, "schoolbook") == 0)
		pretty = 4;
	    else if (strcmp (font, "lucida") == 0)
		pretty = 5;
	    else
		pretty = 2;
	}

	if (text = HTMLGetText (wp->w, pretty)) {
	    Tcl_SetResult (wp->obm->tcl, text, TCL_VOLATILE);
	    free (text);
	}

	return (TCL_OK);
}


/* positionToId -- Return the element id of the HTML element nearest to the
 * given position x,y.
 *
 *  Usage:	id = positionToId x y
 *
 * If there is no element at the given position the first element in the
 * current line is returned.  If we are not positioned to a line, either the
 * beginning or the end of the document is returned.
 */
static int 
htmlPositionToId (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	int element_id, x, y;
	char buf[SZ_NUMBER];

	if (argc < 3)
	    return (TCL_ERROR);

	x = atoi (argv[1]);
	y = atoi (argv[2]);
	element_id = HTMLPositionToId (wp->w, x, y);

	sprintf (buf, "%d", element_id);
	Tcl_SetResult (wp->obm->tcl, buf, TCL_VOLATILE);

	return (TCL_OK);
}


/* idToPosition -- Return the position of an HTML element given its
 * element id.
 *
 *  Usage:	idToPosition id x y
 *
 * If there is no element with the given element id false is returned and
 * the coordinates x,y are undefined.
 */
static int 
htmlIdToPosition (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	ObmContext obm = obj->widget.obm;
	int status, element_id, x, y;
	char buf[SZ_NUMBER];
	char *s_x, *s_y;

	if (argc < 2)
	    return (TCL_ERROR);

	element_id = atoi (argv[1]);
	s_x = (argc > 2) ? argv[2] : NULL;
	s_y = (argc > 3) ? argv[3] : NULL;
	status = HTMLIdToPosition (wp->w, element_id, &x, &y);

	if (status < 0)
	    Tcl_SetResult (obm->tcl, FALSESTR, TCL_STATIC);
	else {
	    if (s_x) {
		sprintf (buf, "%d", x);
		if ((Tcl_SetVar (obm->tcl, s_x, buf, 0)) == NULL) /* MF024 */
		    return (TCL_ERROR);
	    }
	    if (s_y) {
		sprintf (buf, "%d", y);
		if ((Tcl_SetVar (obm->tcl, s_y, buf, 0)) == NULL) /* MF024 */
		    return (TCL_ERROR);
	    }
	    Tcl_SetResult (obm->tcl, TRUESTR, TCL_STATIC);
	}

	return (TCL_OK);
}


/* anchorToPosition -- Return the position of the named anchor.
 *
 *  Usage:	bool = anchorToPosition anchor [x y]
 *
 * If there is no anchor with the given name false is returned and the
 * coordinates x,y are undefined.
 */
static int 
htmlAnchorToPosition (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	ObmContext obm = obj->widget.obm;
	char *anchor, *s_x, *s_y;
	char buf[SZ_NUMBER];
	int status, x, y;

	if (argc < 2)
	    return (TCL_ERROR);

	anchor = argv[1];
	s_x = (argc > 2) ? argv[2] : NULL;
	s_y = (argc > 3) ? argv[3] : NULL;
	status = HTMLAnchorToPosition (wp->w, anchor, &x, &y);

	if (status < 0)
	    Tcl_SetResult (obm->tcl, FALSESTR, TCL_STATIC);
	else {
	    if (s_x) {
		sprintf (buf, "%d", x);
		if ((Tcl_SetVar (obm->tcl, s_x, buf, 0)) == NULL) /* MF024 */
		    return (TCL_ERROR);
	    }
	    if (s_y) {
		sprintf (buf, "%d", y);
		if ((Tcl_SetVar (obm->tcl, s_y, buf, 0)) == NULL) /* MF024 */
		    return (TCL_ERROR);
	    }
	    Tcl_SetResult (obm->tcl, TRUESTR, TCL_STATIC);
	}

	return (TCL_OK);
}


/* anchorToId -- Return the element id of the named anchor.
 *
 *  Usage:	id = anchorToId anchor
 *
 * If there is no anchor with the given name false is returned.
 */
static int 
htmlAnchorToId (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	char buf[SZ_NUMBER];
	int element_id;
	char *anchor;

	if (argc < 2)
	    return (TCL_ERROR);

	anchor = argv[1];
	element_id = HTMLAnchorToId (wp->w, anchor);

	sprintf (buf, "%d", element_id);
	Tcl_SetResult (wp->obm->tcl, buf, TCL_VOLATILE);

	return (TCL_OK);
}


/* gotoId -- Position to the given element given its element id.
 *
 *  Usage:	gotoId element_id
 *
 * An id of zero means go to the top of the document.
 */
static int 
htmlGotoId (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	int element_id;

	if (argc < 2)
	    return (TCL_ERROR);

	element_id = atoi (argv[1]);
	HTMLGotoId (wp->w, element_id);

	return (TCL_OK);
}


/* getHRefs -- Get a list of the HREFs of all the active anchors in the
 * document being displayed.
 *
 *  Usage:	n = getHRefs list
 *
 * The number of HREFs is returned as the function value; zero is returned
 * if there are no HREFs, in which case "list" is undefined.  If the document
 * has HREFs on output list will contain a list of HREFs in the form { {HREF1}
 * {HREF2} ... {HREFn} }.
 *
 * An HREF is a hypertext reference, i.e. hot-link or hypertext link to
 * some other hypertext document that can be referenced by clicking on an
 * anchor in the document being displayed.
 */
static int 
htmlGetHRefs (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	WidgetPrivate wp = &obj->widget;
	ObmContext obm = obj->widget.obm;
	char *a_list, *lbuf, **list;
	char buf[SZ_NUMBER];
	int n;

	if (argc < 2)
	    return (TCL_ERROR);
	else
	    a_list = argv[1];

	if (list = HTMLGetHRefs (wp->w, &n)) {
	    if (!(lbuf = makeList (list, n))) {
		free ((char *)list);
		return (TCL_ERROR);
	    }

	    if ((Tcl_SetVar (obm->tcl, a_list, lbuf, 0)) == NULL) { /* MF024 */
		free ((char *)list);
		XtFree (lbuf);
		return (TCL_ERROR);
	    }

	    free ((char *)list);
	    XtFree (lbuf);
	} else
	    n = 0;

	sprintf (buf, "%d", n);
	Tcl_SetResult (wp->obm->tcl, buf, TCL_VOLATILE);
	return (TCL_OK);
}


/* getImageSrcs -- Get a list of the image sources (SRC=) for all the 
 * inline images referenced by the document being displayed.
 *
 *  Usage:	n = getImageSrcs list
 *
 * The number of SRCs is returned as the function value; zero is returned
 * if there are no SRCs, in which case "list" is undefined.  If the document
 * has SRCs on output the list will contain a list of SRCs in the form
 * { {SRC1} {SRC2} ... {SRCn} }.
 *
 * A SRC is a HREF pointing to an image file.
 */
static int 
htmlGetImageSrcs (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	WidgetPrivate wp = &obj->widget;
	ObmContext obm = obj->widget.obm;
	char *a_list, *lbuf, **list;
	char buf[SZ_NUMBER];
	int n;

	if (argc < 2)
	    return (TCL_ERROR);
	else
	    a_list = argv[1];

	if (list = HTMLGetImageSrcs (wp->w, &n)) {
	    if (!(lbuf = makeList (list, n))) {
		free ((char *)list);
		return (TCL_ERROR);
	    }

	    if ((Tcl_SetVar (obm->tcl, a_list, lbuf, 0)) == NULL) { /* MF024 */
		free ((char *)list);
		XtFree (lbuf);
		return (TCL_ERROR);
	    }

	    free ((char *)list);
	    XtFree (lbuf);
	} else
	    n = 0;

	sprintf (buf, "%d", n);
	Tcl_SetResult (wp->obm->tcl, buf, TCL_VOLATILE);
	return (TCL_OK);
}


/* getLinks -- Get a list of the link tags (<LINK>) referenced by the
 * document being displayed.
 *
 *  Usage:	n = getLinks list
 *
 * The number of links is returned as the function value; zero is returned
 * if there are no links, in which case "list" is undefined.  If there are
 * any links the returned list will have the format { {{href} {role}} ...}
 * where the structure {{href} {role}} describes each link.
 */
static int 
htmlGetLinks (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	WidgetPrivate wp = &obj->widget;
	ObmContext obm = obj->widget.obm;
	char *a_list, *lbuf;
	char buf[SZ_NUMBER];
	LinkInfo *list;
	int nchars, n;

	if (argc < 2)
	    return (TCL_ERROR);
	else
	    a_list = argv[1];

	if (list = HTMLGetLinks (wp->w, &n)) {
	    register char *ip, *op;
	    register int i;

	    /* Determine how much storage we need for the list. */
	    for (i=0, nchars=0;  i < n;  i++) {
		nchars += strlen (list[i].href) + 4;
		nchars += strlen (list[i].role) + 4;
	    }
	    nchars += 5;

	    /* Get the storage. */
	    if (!(lbuf = op = XtMalloc (nchars))) {
		free ((char *)list);
		return (TCL_ERROR);
	    }

	    /* Encode the list as a Tcl list of lists. */
	    *op++ = '{';  *op++ = ' ';
	    for (i=0;  i < n;  i++) {
		*op++ = '{';
		*op++ = '{';
		for (ip=list[i].href;  ip && *ip;  )
		    *op++ = *ip++;
		*op++ = '}';  *op++ = ' ';
		*op++ = '{';
		for (ip=list[i].role;  ip && *ip;  )
		    *op++ = *ip++;
		*op++ = '}';
		*op++ = '}';  *op++ = ' ';
	    }
	    *op++ = '}';
	    *op++ = '\0';

	    if ((Tcl_SetVar (obm->tcl, a_list, lbuf, 0)) == NULL) { /* MF024 */
		free ((char *)list);
		XtFree (lbuf);
		return (TCL_ERROR);
	    }

	    free ((char *)list);
	    XtFree (lbuf);
	} else
	    n = 0;

	sprintf (buf, "%d", n);
	Tcl_SetResult (wp->obm->tcl, buf, TCL_VOLATILE);
	return (TCL_OK);
}


/* makeList -- Take a list of NULL terminated strings and turn it into a
 * Tcl list of strings.
 */
static char *
makeList (list, n)
char **list;
int n;
{
	register char *ip, *op;
	register int i;
	int nchars;
	char *buf;

	/* Determine how much storage we need for the list. */
	for (i=0, nchars=0;  i < n;  i++)
	    nchars += strlen (list[i]) + 4;
	nchars += 5;

	/* Get the storage. */
	if (!(buf = op = XtMalloc (nchars))) {
	    free ((char *)list);
	    return (NULL);
	}

	/* Encode the list as a Tcl list of strings. */
	*op++ = '{';  *op++ = ' ';
	for (i=0;  i < n;  i++) {
	    *op++ = '{';
	    for (ip=list[i];  ip && *ip;  )
		*op++ = *ip++;
	    *op++ = '}';  *op++ = ' ';
	}
	*op++ = '}';
	*op++ = '\0';

	return (buf);
}


/* retestAnchors -- Test each anchor and update the display to indicate
 * the current status of the anchor.
 *
 *  Usage:	retestAnchors
 *
 * retestAnchors should be called after loading new text into a widget,
 * or when the status of one or more anchors has changed, e.g. after a
 * given URL has been visited.
 */
static int 
htmlRetestAnchors (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;

	HTMLRetestAnchors (wp->w, NULL, 0);
	return (TCL_OK);
}


/* setSelection -- Set the current text selection to the text bracketed by
 * the input start and end element refs.
 *
 *  Usage:	setSelection start end
 *
 * "start" and "end" are elements refs such as returned by searchText.
 * An element ref is a structure of the form {element_id offset} specifying
 * the element id within the document, and the character offset within
 * that element.
 */
static int 
htmlSetSelection (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	ElementRef start, end;
	char *ip = (char *)NULL;

	if (argc < 3)
	    return (TCL_ERROR);

	ip = (char *)NULL;
	start.id  = strtol (&argv[1][1], &ip, 0);
	start.pos = strtol (ip, &ip, 0);
	if (ip == argv[1])
	    return (TCL_ERROR);

	ip = (char *)NULL;
	end.id  = strtol (&argv[2][1], &ip, 0);
	end.pos = strtol (ip, &ip, 0);
	if (ip == argv[2])
	    return (TCL_ERROR);

	HTMLSetSelection (wp->w, &start, &end);
	return (TCL_OK);
}


/* getSelection -- Get the selected text, if any.
 *
 *  Usage:	text = getSelection
 *
 * An empty string is returned if there is no current text selection.
 */
static int 
htmlGetSelection (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	char *text, *start, *end, *insert;

	text = HTMLGetTextAndSelection (wp->w, &start, &end, &insert);
	if (text && start) {
	    int nchars = end - start + 1;
	    start[nchars] = '\0';
	    Tcl_SetResult (wp->obm->tcl, start, TCL_VOLATILE);
	}

	if (text)
	    free (text);
	return (TCL_OK);
}


/* clearSelection -- Clear the current selection, if any.
 *
 *  Usage:	clearSelection
 */
static int 
htmlClearSelection (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;

	HTMLClearSelection (wp->w);
	return (TCL_OK);
}


/* searchText -- Search the document for the given pattern.
 *
 *  Usage:	bool = searchText pattern start end [direction [search_type]]
 *
 *	direction	"forward" or "backward"
 *	search_type	"caseSensitive" or "caseless"
 *
 * If the search is successful start and end are set to the element refs
 * of the matched region and the function returns a true (nonzero) value.
 * False is returned if the search fails.  An element ref is a structure of
 * the form {element_id offset} specifying the element id within the document,
 * and the character offset within that element.  The search will automatically
 * wrap around the page if not found initially.
 *
 */
static int 
htmlSearchText (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	register HTMLClassData gcd = (HTMLClassData) msg;
	HTMLObject obj = (HTMLObject) gcd->object[gcd->level];
	register WidgetPrivate wp = &obj->widget;
	ObmContext obm = obj->widget.obm;
	char *pattern, *a_start, *a_end;
	int backward = 0, caseless = 1;
	static ElementRef start, end;
  	static char patstr[64];
	int status, again = 1;

	if (argc < 4)
	    return (TCL_ERROR);

	pattern = argv[1];
	a_start = argv[2];
	a_end = argv[3];
	backward = 0;
	if (argc > 4)
	    backward = (strcmp (argv[4], "backward") == 0);
	caseless = 0;
	if (argc > 5)
	    caseless = (strcmp (argv[5], "caseless") == 0);

	/* See whether the pattern has changed and we need to reset the
	 * start and end element refs.
	 */
	if (strcmp (pattern, patstr) != 0) {
retry: 	    start.id = start.pos = 0;
	    end.id = end.pos = 0;
	    strcpy (patstr, "");
	    again = 0;
	}

	/* Do the search. */
	status = HTMLSearchText (wp->w, pattern,
	    &start, &end, backward, caseless);

	if (status == 1) {
	    char buf[SZ_LINE];
	    sprintf (buf, "{%d %d}", start.id, start.pos);
	    if ((Tcl_SetVar (obm->tcl, a_start, buf, 0)) == NULL) /* MF024 */
		return (TCL_ERROR);
	    sprintf (buf, "{%d %d}", end.id, end.pos);
	    if ((Tcl_SetVar (obm->tcl, a_end, buf, 0)) == NULL)   /* MF024 */
		return (TCL_ERROR);
	    Tcl_SetResult (wp->obm->tcl, TRUESTR, TCL_STATIC);
	} else {
	    if (again == 1)
		goto retry;
	    Tcl_SetResult (wp->obm->tcl, FALSESTR, TCL_STATIC);
	}

	/* Save the pattern string so we can reset later if it changes. */
	strcpy (patstr, pattern);

	return (TCL_OK);
}


/* AddCallback -- Post a callback for a HTML widget event.
 *
 * Usage:	addCallback procedure-name [callback-type]
 *
 * The recognized HTML callbacks are
 *
 *	anchor			Called to load a new URL.
 *
 *	testAnchor		Called to test whether a given URL has
 *				been previously visited.
 *
 *	pointerMotion		Called when the pointer enters an object
 *				which has a URL.
 *
 *	submitForm		Called when a form is submitted from within
 *				the document being viewed.
 *
 *	link			Called when a <LINK> tag is encountered
 *				while loading text.
 *
 * The default callback type is "anchor", which is called when the user
 * selects a new URL while viewing a document.
 */
static int 
htmlAddCallback (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	HTMLObject obj = (HTMLObject) msg->object[msg->level];
	register WidgetPrivate wp = &obj->widget;
	register HTMLPrivate hp = &obj->html;
	register Widget w = wp->w;
	char *userproc, *callback_type;
	ObmCallback cb, new;
	int type;

	if (argc < 2)
	    return (TCL_ERROR);

	userproc = argv[1];
	callback_type = (argc > 2) ? argv[2] : "anchor";
	if (!(type = cb_decode (callback_type)))
	    return (TCL_ERROR);

	/* Initialize callback descriptor. */
	new = (ObmCallback) XtCalloc (1, sizeof (obmCallback));
	new->u.obj = (ObmObject) obj;
	new->callback_type = type;
	strncpy (new->name, userproc, SZ_NAME);

	/* Append descriptor to callback list for widget. */
	for (cb = hp->callback_list;  cb && cb->next;  cb = cb->next)
	    ;
	if (cb)
	    cb->next = new;
	else
	    hp->callback_list = new;

	return (TCL_OK);
}


/* DeleteCallback -- Delete a HTML callback.
 *
 *  Usage:	deleteCallback procedure [callback_type]
 *
 * If a callback type is specified all entries of type callback_type for
 * the named procedure are deleted, else all entries of any type for the
 * named procedure are deleted.
 */
static int 
htmlDeleteCallback (msg, tcl, argc, argv)
MsgContext msg;
Tcl_Interp *tcl;
int argc;
char **argv;
{
	HTMLObject obj = (HTMLObject) msg->object[msg->level];
	register HTMLPrivate hp = &obj->html;
	register ObmCallback cb, prev, next;
	char *procedure, *callback_type;
	int type;

	if (argc < 2)
	    return (TCL_ERROR);

	procedure = argv[1];
	callback_type = (argc > 2) ? argv[2] : NULL;
	type = callback_type ? cb_decode(callback_type) : 0;

	/* Locate and delete procedure entry in callback list. */
	for (prev=NULL, cb=hp->callback_list;  cb;  prev=cb, cb=next) {
	    next = cb->next;
	    if (strcmp (cb->name, procedure) == 0 &&
		    (!type || cb->callback_type == type)) {
		if (prev)
		    prev->next = next;
		else
		    hp->callback_list = next;
		XtFree ((char *)cb);
	    }
	}

	return (TCL_OK);
}


/* anchorCallback -- Callback procedure called by the HTML widget when an
 * anchor (URL) is selected.
 *
 * Calling sequence:
 *
 *	userproc widget cbtype event text href element_id
 *
 * All callbacks registered with the current widget for the anchor callback
 * are called in the order in which they were registered.
 */
static void
anchorCallback (w, client_data, call_data)
Widget w;
XtPointer client_data;
XtPointer call_data;
{
	register char *ip, *op;
	register ObmCallback cb;
	register WbAnchorCallbackData *ap = (WbAnchorCallbackData *)call_data;
	HTMLObject obj = (HTMLObject) client_data;
	ObmContext obm = obj->widget.obm;
	char *text, *href, *none = "none";
	char event_type[SZ_LINE];
	char element_id[SZ_NUMBER];
	int status;

	text = ap->text ? ap->text : none;
	href = ap->href ? ap->href : none;
	sprintf (element_id, "%d", ap->element_id);
	op = event_type;

	/* Compose the event type information.  This is the name of the
	 * key typed, or "Button1", "Button2", etc. for the mouse buttons.
	 */
	switch (ap->event->type) {
	case KeyPress:
	case KeyRelease:
	    {	XKeyPressedEvent *ev = (XKeyPressedEvent *) ap->event;
		char buf[20];
		int n;

		if ((n = XLookupString(ev,buf,sizeof(buf),NULL,NULL)) > 0) {
		    for (ip=buf;  --n >= 0;  )
			if (*ip <= ' ') {
			    *op++ = '^';
			    *op++ = *ip++ + 'A' - 1;
			} else if (isprint (*ip)) {
			    *op++ = *ip++;
			} else
			    ip++;
		} else {
		    /* This case occurs when only a modifier is typed. */
		    for (ip = "??";  *op++ = *ip++; )
			;
		}
		*op = '\0';
	    }
	    break;

	case ButtonPress:
	case ButtonRelease:
	    {	XButtonPressedEvent *ev = (XButtonPressedEvent *) ap->event;
		sprintf (op, "Button%d", ev->button);
	    }
	    break;
	default:
	    strcpy (event_type, "unknown");
	}

	/* Call any registered callback functions. */
	for (cb = obj->html.callback_list;  cb;  cb = cb->next) {
	    if (cb->callback_type != CB_Anchor)
		continue;

	    status = Tcl_VarEval (obm->tcl,
		cb->name, " ",
		obj->core.name, " ",
		cb_encode(cb->callback_type), " ",
		event_type, " ",
		"{", text, "} ",
		"{", href, "} ",
		element_id,
		NULL);

	    if (status != TCL_OK)
		cb_error (obm, cb);
	}
}


/* testAnchorCallback -- Callback procedure called by the HTML widget to
 * test whether a given anchor (URL) has been previously visited.
 *
 * Calling sequence:
 *
 *	userproc widget cbtype href
 *
 * A nonzero value should be returned by the userproc if the given anchor
 * has been visited previously, otherwise a zero should be returned.
 */
static int
testAnchorCallback (w, client_data, href)
Widget w;
XtPointer client_data;
char *href;
{
	register ObmCallback cb;
	register HTMLObject obj = (HTMLObject) client_data;
	register ObmContext obm = obj->widget.obm;
	int status, retval = 0;

	/* Call any registered callback functions. */
	for (cb = obj->html.callback_list;  cb;  cb = cb->next) {
	    if (cb->callback_type != CB_TestAnchor)
		continue;

	    status = Tcl_VarEval (obm->tcl,
		cb->name, " ",
		obj->core.name, " ",
		cb_encode(cb->callback_type), " ",
		"{", href, "} ",
		NULL);

	    if (status != TCL_OK)
		cb_error (obm, cb);
	    else if (atoi (obm->tcl->result))
		retval = 1;
	}

	return (retval);
}


/* submitFormCallback -- Callback procedure called by the HTML widget when
 * a form is submitted from the document.
 *
 * Calling sequence:
 *
 *	userproc widget cbtype event attrs href method enctype encentity
 *
 * "widget" is the name of the HTML widget which generated the callback.
 * "cbtype" is the type of callback, i.e., "submitForm".  "event" is the
 * key/button event which triggered the callback, e.g. "Button1".
 *
 * "attrs" is a list of attribute-value pairs defining the contents of the
 * form.  That is, a list of the form { {attr1 value1} {attr2 value2} ... }.
 * 
 * The final block of arguments deal with how to process or deliver the form.
 * "href", "method", "enctype", and "encentity" are strings defined by the
 * HTML form.  The application is free to use these as it wishes, except for
 * an HTML form query where the meaning of these fields is well defined.
 * The "href" field is normally the URL to which the form is to be submitted,
 * while "method" is the method to be used to submit the form.
 */
static void
submitFormCallback (w, client_data, call_data)
Widget w;
XtPointer client_data;
XtPointer call_data;
{
	register char *ip, *op;
	register ObmCallback cb;
	register WbFormCallbackData *fp = (WbFormCallbackData *)call_data;
	HTMLObject obj = (HTMLObject) client_data;
	ObmContext obm = obj->widget.obm;

	char *href, *method, *enctype, *encentity;
	char *abuf, event_type[SZ_LINE];
	char *none = "none";
	int status, i, n;

	href = fp->href ? fp->href : none;
	method = fp->method ? fp->method : none;
	enctype = fp->enctype ? fp->enctype : none;
	encentity = fp->enc_entity ? fp->enc_entity : none;
	op = event_type;

	/* Compose the event type information.  This is the name of the
	 * key typed, or "Button1", "Button2", etc. for the mouse buttons.
	 */
	switch (fp->event->type) {
	case KeyPress:
	case KeyRelease:
	    {	XKeyPressedEvent *ev = (XKeyPressedEvent *) fp->event;
		char buf[20];
		int n;

		if ((n = XLookupString(ev,buf,sizeof(buf),NULL,NULL)) > 0) {
		    for (ip=buf;  --n >= 0;  )
			if (*ip <= ' ') {
			    *op++ = '^';
			    *op++ = *ip++ + 'A' - 1;
			} else if (isprint (*ip)) {
			    *op++ = *ip++;
			} else
			    ip++;
		} else {
		    /* This case occurs when only a modifier is typed. */
		    for (ip = "??";  *op++ = *ip++; )
			;
		}
		*op = '\0';
	    }
	    break;

	case ButtonPress:
	case ButtonRelease:
	    {	XButtonPressedEvent *ev = (XButtonPressedEvent *) fp->event;
		sprintf (op, "Button%d", ev->button);
	    }
	    break;
	default:
	    strcpy (event_type, "unknown");
	}

	/* Get storage for the attribute list. */
	for (i=0, n=0;  i < fp->attribute_count;  i++) {
	    n += strlen (fp->attribute_names[i]);
	    n += strlen (fp->attribute_values[i]);
	    n += 10;
	}
	if (!(abuf = XtMalloc (n)))
	    return;

	/* Construct the attribute list.
	 */
	for (i=0, op=abuf;  i < fp->attribute_count;  i++) {
	    *op++ = '{';

	    *op++ = '{';
	    for (ip = fp->attribute_names[i];  ip && *ip;  )
		*op++ = *ip++;
	    *op++ = '}';  *op++ = ' ';

	    *op++ = '{';
	    for (ip = fp->attribute_values[i];  ip && *ip;  )
		*op++ = *ip++;
	    *op++ = '}';

	    *op++ = '}';  *op++ = ' ';
	}
	*op = '\0';

	/* Call any registered callback functions. */
	for (cb = obj->html.callback_list;  cb;  cb = cb->next) {
	    if (cb->callback_type != CB_SubmitForm)
		continue;

	    status = Tcl_VarEval (obm->tcl,
		cb->name, " ",
		obj->core.name, " ",
		cb_encode(cb->callback_type), " ",
		event_type, " ",
		"{ ", abuf, "} ",
		href, " ",
		method, " ",
		enctype, " ",
		encentity, " ",
		NULL);

	    if (status != TCL_OK)
		cb_error (obm, cb);
	}

	XtFree (abuf);
}


/* linkCallback -- Callback procedure called by the HTML widget when
 * a <LINK> directive is encountered while loading text into the widget.
 *
 * Calling sequence:
 *
 *	userproc widget cbtype href role
 *
 * All callbacks registered with the current widget for the callback
 * are called in the order in which they were registered.
 */
static void
linkCallback (w, client_data, call_data)
Widget w;
XtPointer client_data;
XtPointer call_data;
{
	register char *ip, *op;
	register ObmCallback cb;
	LinkInfo *l_info = (LinkInfo *) call_data;
	HTMLObject obj = (HTMLObject) client_data;
	ObmContext obm = obj->widget.obm;
	char *href, *role, *none = "none";
	int status;

	href = l_info->href ? l_info->href : none;
	role = l_info->role ? l_info->role : none;

	/* Call any registered callback functions. */
	for (cb = obj->html.callback_list;  cb;  cb = cb->next) {
	    if (cb->callback_type != CB_Link)
		continue;

	    status = Tcl_VarEval (obm->tcl,
		cb->name, " ",
		obj->core.name, " ",
		cb_encode(cb->callback_type), " ",
		href, " ",
		role, " ",
		NULL);

	    if (status != TCL_OK)
		cb_error (obm, cb);
	}
}


/* pointerMotionCallback -- Callback procedure called by the HTML widget when
 * the pointer enters an anchor.
 *
 * Calling sequence:
 *
 *	userproc widget cbtype href
 */
static void
pointerMotionCallback (w, client_data, href)
Widget w;
XtPointer client_data;
char *href;
{
	register ObmCallback cb;
	register HTMLObject obj = (HTMLObject) client_data;
	register ObmContext obm = obj->widget.obm;
	int status;

	/* Call any registered callback functions. */
	for (cb = obj->html.callback_list;  cb;  cb = cb->next) {
	    if (cb->callback_type != CB_PointerMotion)
		continue;

	    status = Tcl_VarEval (obm->tcl,
		cb->name, " ",
		obj->core.name, " ",
		cb_encode(cb->callback_type), " ",
		"{", href, "} ",
		NULL);

	    if (status != TCL_OK)
		cb_error (obm, cb);
	}
}


/* cb_error -- Convenience routine to return an error from a callback.
 */
static void
cb_error (obm, cb)
register ObmContext obm;
register ObmCallback cb;
{
	register Tcl_Interp *tcl = obm->tcl;
	char *errstr = Tcl_GetVar (tcl, "errorInfo", 0);
	fprintf (stderr, "Error on line %d in %s: %s\n",
	    tcl->errorLine, cb->name,
	    errstr ? errstr : tcl->result);
}

/* cb_decode -- Convert a callback_type string to a callback type code.
 */
static int
cb_decode (callback_type)
register char *callback_type;
{
	register int type = 0;

	if (strcmp (callback_type, "anchor") == 0)
	    type = CB_Anchor;
	else if (strcmp (callback_type, "testAnchor") == 0)
	    type = CB_TestAnchor;
	else if (strcmp (callback_type, "pointerMotion") == 0)
	    type = CB_PointerMotion;
	else if (strcmp (callback_type, "submitForm") == 0)
	    type = CB_SubmitForm;
	else if (strcmp (callback_type, "link") == 0)
	    type = CB_Link;

	return (type);
}

/* cb_encode -- Convert a callback_type string to a callback type code.
 */
static char *
cb_encode (callback_type)
int callback_type;
{
	register char *type = "unknown";

	switch (callback_type) {
	case CB_Anchor:
	    type = "anchor";
	    break;
	case CB_TestAnchor:
	    type = "testAnchor";
	    break;
	case CB_PointerMotion:
	    type = "pointerMotion";
	    break;
	case CB_SubmitForm:
	    type = "submitForm";
	    break;
	case CB_Link:
	    type = "link";
	    break;
	}

	return (type);
}