libtk/generic/tkTest.c

/*
 * tkTest.c --
 *
 *	This file contains C command procedures for a bunch of additional
 *	Tcl commands that are used for testing out Tcl's C interfaces.
 *	These commands are not normally included in Tcl applications;
 *	they're only used for testing.
 *
 * Copyright (c) 1993-1994 The Regents of the University of California.
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tkTest.c 1.35 96/10/03 11:22:26
 */

#include "tkInt.h"

#ifdef WIN_TCL
#include "tkWinInt.h"
#endif

/*
 * The table below describes events and is used by the "testevent"
 * command.
 */

typedef struct {
    char *name;			/* Name of event. */
    int type;			/* Event type for X, such as
				 * ButtonPress. */
} EventInfo;

static EventInfo eventArray[] = {
    {"Motion",		MotionNotify},
    {"Button",		ButtonPress},
    {"ButtonPress",	ButtonPress},
    {"ButtonRelease",	ButtonRelease},
    {"Colormap",	ColormapNotify},
    {"Enter",		EnterNotify},
    {"Leave",		LeaveNotify},
    {"Expose",		Expose},
    {"FocusIn",		FocusIn},
    {"FocusOut",	FocusOut},
    {"Keymap",		KeymapNotify},
    {"Key",		KeyPress},
    {"KeyPress",	KeyPress},
    {"KeyRelease",	KeyRelease},
    {"Property",	PropertyNotify},
    {"ResizeRequest",	ResizeRequest},
    {"Circulate",	CirculateNotify},
    {"Configure",	ConfigureNotify},
    {"Destroy",		DestroyNotify},
    {"Gravity",		GravityNotify},
    {"Map",		MapNotify},
    {"Reparent",	ReparentNotify},
    {"Unmap",		UnmapNotify},
    {"Visibility",	VisibilityNotify},
    {"CirculateRequest",CirculateRequest},
    {"ConfigureRequest",ConfigureRequest},
    {"MapRequest",	MapRequest},
    {(char *) NULL,	0}
};

/*
 * The defines and table below are used to classify events into
 * various groups.  The reason for this is that logically identical
 * fields (e.g. "state") appear at different places in different
 * types of events.  The classification masks can be used to figure
 * out quickly where to extract information from events.
 */

#define KEY_BUTTON_MOTION	0x1
#define CROSSING		0x2
#define FOCUS			0x4
#define EXPOSE			0x8
#define VISIBILITY		0x10
#define CREATE			0x20
#define MAP			0x40
#define REPARENT		0x80
#define CONFIG			0x100
#define CONFIG_REQ		0x200
#define RESIZE_REQ		0x400
#define GRAVITY			0x800
#define PROP			0x1000
#define SEL_CLEAR		0x2000
#define SEL_REQ			0x4000
#define SEL_NOTIFY		0x8000
#define COLORMAP		0x10000
#define MAPPING			0x20000

static int flagArray[LASTEvent] = {
   /* Not used */		0,
   /* Not used */		0,
   /* KeyPress */		KEY_BUTTON_MOTION,
   /* KeyRelease */		KEY_BUTTON_MOTION,
   /* ButtonPress */		KEY_BUTTON_MOTION,
   /* ButtonRelease */		KEY_BUTTON_MOTION,
   /* MotionNotify */		KEY_BUTTON_MOTION,
   /* EnterNotify */		CROSSING,
   /* LeaveNotify */		CROSSING,
   /* FocusIn */		FOCUS,
   /* FocusOut */		FOCUS,
   /* KeymapNotify */		0,
   /* Expose */			EXPOSE,
   /* GraphicsExpose */		EXPOSE,
   /* NoExpose */		0,
   /* VisibilityNotify */	VISIBILITY,
   /* CreateNotify */		CREATE,
   /* DestroyNotify */		0,
   /* UnmapNotify */		0,
   /* MapNotify */		MAP,
   /* MapRequest */		0,
   /* ReparentNotify */		REPARENT,
   /* ConfigureNotify */	CONFIG,
   /* ConfigureRequest */	CONFIG_REQ,
   /* GravityNotify */		0,
   /* ResizeRequest */		RESIZE_REQ,
   /* CirculateNotify */	0,
   /* CirculateRequest */	0,
   /* PropertyNotify */		PROP,
   /* SelectionClear */		SEL_CLEAR,
   /* SelectionRequest */	SEL_REQ,
   /* SelectionNotify */	SEL_NOTIFY,
   /* ColormapNotify */		COLORMAP,
   /* ClientMessage */		0,
   /* MappingNotify */		MAPPING
};

/*
 * The following data structure represents the master for a test
 * image:
 */

typedef struct TImageMaster {
    Tk_ImageMaster master;	/* Tk's token for image master. */
    Tcl_Interp *interp;		/* Interpreter for application. */
    int width, height;		/* Dimensions of image. */
    char *imageName;		/* Name of image (malloc-ed). */
    char *varName;		/* Name of variable in which to log
				 * events for image (malloc-ed). */
} TImageMaster;

/*
 * The following data structure represents a particular use of a
 * particular test image.
 */

typedef struct TImageInstance {
    TImageMaster *masterPtr;	/* Pointer to master for image. */
    XColor *fg;			/* Foreground color for drawing in image. */
    GC gc;			/* Graphics context for drawing in image. */
} TImageInstance;

/*
 * The type record for test images:
 */

static int		ImageCreate _ANSI_ARGS_((Tcl_Interp *interp,
			    char *name, int argc, char **argv,
			    Tk_ImageType *typePtr, Tk_ImageMaster master,
			    ClientData *clientDataPtr));
static ClientData	ImageGet _ANSI_ARGS_((Tk_Window tkwin,
			    ClientData clientData));
static void		ImageDisplay _ANSI_ARGS_((ClientData clientData,
			    Display *display, Drawable drawable,
			    int imageX, int imageY, int width,
			    int height, int drawableX,
			    int drawableY));
static void		ImageFree _ANSI_ARGS_((ClientData clientData,
			    Display *display));
static void		ImageDelete _ANSI_ARGS_((ClientData clientData));

static Tk_ImageType imageType = {
    "test",			/* name */
    ImageCreate,		/* createProc */
    ImageGet,			/* getProc */
    ImageDisplay,		/* displayProc */
    ImageFree,			/* freeProc */
    ImageDelete,		/* deleteProc */
    (Tk_ImageType *) NULL	/* nextPtr */
};

/*
 * One of the following structures describes each of the interpreters
 * created by the "testnewapp" command.  This information is used by
 * the "testdeleteinterps" command to destroy all of those interpreters.
 */

typedef struct NewApp {
    Tcl_Interp *interp;		/* Token for interpreter. */
    struct NewApp *nextPtr;	/* Next in list of new interpreters. */
} NewApp;

static NewApp *newAppPtr = NULL;
				/* First in list of all new interpreters. */

/*
 * Declaration for the square widget's class command procedure:
 */

extern int SquareCmd _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int argc, char *argv[]));

/*
 * Forward declarations for procedures defined later in this file:
 */

int			Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp));
static int		ImageCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
#ifdef WIN_TCL
static int		TestclipboardCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
#endif
static int		TestdeleteappsCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TesteventCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestmakeexistCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestsendCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));

/*
 *----------------------------------------------------------------------
 *
 * Tktest_Init --
 *
 *	This procedure performs intialization for the Tk test
 *	suite exensions.
 *
 * Results:
 *	Returns a standard Tcl completion code, and leaves an error
 *	message in interp->result if an error occurs.
 *
 * Side effects:
 *	Creates several test commands.
 *
 *----------------------------------------------------------------------
 */

int
Tktest_Init(interp)
    Tcl_Interp *interp;		/* Interpreter for application. */
{
    static int initialized = 0;

    /*
     * Create additional commands for testing Tk.
     */

    if (Tcl_PkgProvide(interp, "Tktest", TK_VERSION) == TCL_ERROR) {
        return TCL_ERROR;
    }

    Tcl_CreateCommand(interp, "square", SquareCmd,
	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
#ifdef WIN_TCL
    Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd,
	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
#endif
    Tcl_CreateCommand(interp, "testdeleteapps", TestdeleteappsCmd,
	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testevent", TesteventCmd,
	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd,
	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testsend", TestsendCmd,
	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);

    /*
     * Create test image type.
     */

    if (!initialized) {
	initialized = 1;
	Tk_CreateImageType(&imageType);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestclipboardCmd --
 *
 *	This procedure implements the testclipboard command. It provides
 *	a way to determine the actual contents of the Windows clipboard.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifdef WIN_TCL
static int
TestclipboardCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Main window for application. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    TkWindow *winPtr = (TkWindow *) clientData;
    HGLOBAL handle;
    char *data;

    if (OpenClipboard(NULL)) {
	handle = GetClipboardData(CF_TEXT);
	if (handle != NULL) {
	    data = GlobalLock(handle);
	    Tcl_AppendResult(interp, data, (char *) NULL);
	    GlobalUnlock(handle);
	}
	CloseClipboard();
    }
    return TCL_OK;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * TestdeleteappsCmd --
 *
 *	This procedure implements the "testdeleteapps" command.  It cleans
 *	up all the interpreters left behind by the "testnewapp" command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	All the intepreters created by previous calls to "testnewapp"
 *	get deleted.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TestdeleteappsCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Main window for application. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    NewApp *nextPtr;

    while (newAppPtr != NULL) {
	nextPtr = newAppPtr->nextPtr;
	Tcl_DeleteInterp(newAppPtr->interp);
	ckfree((char *) newAppPtr);
	newAppPtr = nextPtr;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TesteventCmd --
 *
 *	This procedure implements the "testevent" command.  It allows
 *	events to be generated on the fly, for testing event-handling.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates and handles events.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TesteventCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Main window for application. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tk_Window main = (Tk_Window) clientData;
    Tk_Window tkwin, tkwin2;
    XEvent event;
    EventInfo *eiPtr;
    char *field, *value;
    int i, number, flags;
    KeySym keysym;

    if ((argc < 3) || !(argc & 1)) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" window type ?field value field value ...?\"",
		(char *) NULL);
	return TCL_ERROR;
    }
    tkwin = Tk_NameToWindow(interp, argv[1], main);
    if (tkwin == NULL) {
	return TCL_ERROR;
    }

    /*
     * Get the type of the event.
     */

    memset((VOID *) &event, 0, sizeof(event));
    for (eiPtr = eventArray; ; eiPtr++) {
	if (eiPtr->name == NULL) {
	    Tcl_AppendResult(interp, "bad event type \"", argv[2],
		    "\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (strcmp(eiPtr->name, argv[2]) == 0) {
	    event.xany.type = eiPtr->type;
	    break;
	}
    }

    /*
     * Fill in fields that are common to all events.
     */

    event.xany.serial = NextRequest(Tk_Display(tkwin));
    event.xany.send_event = False;
    event.xany.window = Tk_WindowId(tkwin);
    event.xany.display = Tk_Display(tkwin);

    /*
     * Process the remaining arguments to fill in additional fields
     * of the event.
     */

    flags = flagArray[event.xany.type];
    for (i = 3; i < argc; i += 2) {
	field = argv[i];
	value = argv[i+1];
	if (strcmp(field, "-above") == 0) {
	    tkwin2 = Tk_NameToWindow(interp, value, main);
	    if (tkwin2 == NULL) {
		return TCL_ERROR;
	    }
	    event.xconfigure.above = Tk_WindowId(tkwin2);
	} else if (strcmp(field, "-borderwidth") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xcreatewindow.border_width = number;
	} else if (strcmp(field, "-button") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xbutton.button = number;
	} else if (strcmp(field, "-count") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (flags & EXPOSE) {
		event.xexpose.count = number;
	    } else if (flags & MAPPING) {
		event.xmapping.count = number;
	    }
	} else if (strcmp(field, "-detail") == 0) {
	    if (flags & (CROSSING|FOCUS)) {
		if (strcmp(value, "NotifyAncestor") == 0) {
		    number = NotifyAncestor;
		} else if (strcmp(value, "NotifyVirtual") == 0) {
		    number = NotifyVirtual;
		} else if (strcmp(value, "NotifyInferior") == 0) {
		    number = NotifyInferior;
		} else if (strcmp(value, "NotifyNonlinear") == 0) {
		    number = NotifyNonlinear;
		} else if (strcmp(value, "NotifyNonlinearVirtual") == 0) {
		    number = NotifyNonlinearVirtual;
		} else if (strcmp(value, "NotifyPointer") == 0) {
		    number = NotifyPointer;
		} else if (strcmp(value, "NotifyPointerRoot") == 0) {
		    number = NotifyPointerRoot;
		} else if (strcmp(value, "NotifyDetailNone") == 0) {
		    number = NotifyDetailNone;
		} else {
		    Tcl_AppendResult(interp, "bad detail \"", value, "\"",
			    (char *) NULL);
		    return TCL_ERROR;
		}
		if (flags & FOCUS) {
		    event.xfocus.detail = number;
		} else {
		    event.xcrossing.detail = number;
		}
	    } else if (flags & CONFIG_REQ) {
		if (strcmp(value, "Above") == 0) {
		    number = Above;
		} else if (strcmp(value, "Below") == 0) {
		    number = Below;
		} else if (strcmp(value, "TopIf") == 0) {
		    number = TopIf;
		} else if (strcmp(value, "BottomIf") == 0) {
		    number = BottomIf;
		} else if (strcmp(value, "Opposite") == 0) {
		    number = Opposite;
		} else {
		    Tcl_AppendResult(interp, "bad detail \"", value, "\"",
			    (char *) NULL);
		    return TCL_ERROR;
		}
		event.xconfigurerequest.detail = number;
	    }
	} else if (strcmp(field, "-focus") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xcrossing.focus = number;
	} else if (strcmp(field, "-height") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (flags & EXPOSE) {
		 event.xexpose.height = number;
	    } else if (flags & (CONFIG|CONFIG_REQ)) {
		event.xconfigure.height = number;
	    } else if (flags & RESIZE_REQ) {
		event.xresizerequest.height = number;
	    }
	} else if (strcmp(field, "-keycode") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xkey.keycode = number;
	} else if (strcmp(field, "-keysym") == 0) {
	    keysym = TkStringToKeysym(value);
	    if (keysym == NoSymbol) {
		Tcl_AppendResult(interp, "unknown keysym \"", value,
			"\"", (char *) NULL);
		return TCL_ERROR;
	    }
	    number = XKeysymToKeycode(event.xany.display, keysym);
	    if (number == 0) {
		Tcl_AppendResult(interp, "no keycode for keysym \"", value,
			"\"", (char *) NULL);
		return TCL_ERROR;
	    }
	    event.xkey.keycode = number;
	} else if (strcmp(field, "-mode") == 0) {
	    if (strcmp(value, "NotifyNormal") == 0) {
		number = NotifyNormal;
	    } else if (strcmp(value, "NotifyGrab") == 0) {
		number = NotifyGrab;
	    } else if (strcmp(value, "NotifyUngrab") == 0) {
		number = NotifyUngrab;
	    } else if (strcmp(value, "NotifyWhileGrabbed") == 0) {
		number = NotifyWhileGrabbed;
	    } else {
		Tcl_AppendResult(interp, "bad mode \"", value, "\"",
			(char *) NULL);
		return TCL_ERROR;
	    }
	    if (flags & CROSSING) {
		event.xcrossing.mode = number;
	    } else if (flags & FOCUS) {
		event.xfocus.mode = number;
	    }
	} else if (strcmp(field, "-override") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (flags & CREATE) {
		event.xcreatewindow.override_redirect = number;
	    } else if (flags & MAP) {
		event.xmap.override_redirect = number;
	    } else if (flags & REPARENT) {
		event.xreparent.override_redirect = number;
	    } else if (flags & CONFIG) {
		event.xconfigure.override_redirect = number;
	    }
	} else if (strcmp(field, "-place") == 0) {
	    if (strcmp(value, "PlaceOnTop") == 0) {
		event.xcirculate.place = PlaceOnTop;
	    } else if (strcmp(value, "PlaceOnBottom") == 0) {
		event.xcirculate.place = PlaceOnBottom;
	    } else if (strcmp(value, "bogus") == 0) {
		event.xcirculate.place = 147;
	    } else {
		Tcl_AppendResult(interp, "bad place \"", value, "\"",
			(char *) NULL);
		return TCL_ERROR;
	    }
	} else if (strcmp(field, "-root") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xkey.root = number;
	} else if (strcmp(field, "-rootx") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xkey.x_root = number;
	} else if (strcmp(field, "-rooty") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xkey.y_root = number;
	} else if (strcmp(field, "-sendevent") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xany.send_event = number;
	} else if (strcmp(field, "-serial") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xany.serial = number;
	} else if (strcmp(field, "-state") == 0) {
	    if (flags & KEY_BUTTON_MOTION) {
		if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		    return TCL_ERROR;
		}
		event.xkey.state = number;
	    } else if (flags & CROSSING) {
		if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		    return TCL_ERROR;
		}
		event.xcrossing.state = number;
	    } else if (flags & VISIBILITY) {
		if (strcmp(value, "VisibilityUnobscured") == 0) {
		    number = VisibilityUnobscured;
		} else if (strcmp(value, "VisibilityPartiallyObscured") == 0) {
		    number = VisibilityPartiallyObscured;
		} else if (strcmp(value, "VisibilityFullyObscured") == 0) {
		    number = VisibilityFullyObscured;
		} else {
		    Tcl_AppendResult(interp, "bad state \"", value, "\"",
			    (char *) NULL);
		    return TCL_ERROR;
		}
		event.xvisibility.state = number;
	    }
	} else if (strcmp(field, "-subwindow") == 0) {
	    tkwin2 = Tk_NameToWindow(interp, value, main);
	    if (tkwin2 == NULL) {
		return TCL_ERROR;
	    }
	    event.xkey.subwindow = Tk_WindowId(tkwin2);
	} else if (strcmp(field, "-time") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (flags & (KEY_BUTTON_MOTION|PROP|SEL_CLEAR)) {
		event.xkey.time = (Time) number;
	    } else if (flags & SEL_REQ) {
		event.xselectionrequest.time = (Time) number;
	    } else if (flags & SEL_NOTIFY) {
		event.xselection.time = (Time) number;
	    }
	} else if (strcmp(field, "-valueMask") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    event.xconfigurerequest.value_mask = number;
	} else if (strcmp(field, "-width") == 0) {
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (flags & EXPOSE) {
		event.xexpose.width = number;
	    } else if (flags & (CONFIG|CONFIG_REQ)) {
		event.xconfigure.width = number;
	    } else if (flags & RESIZE_REQ) {
		event.xresizerequest.width = number;
	    }
	} else if (strcmp(field, "-window") == 0) {
	    tkwin2 = Tk_NameToWindow(interp, value, main);
	    if (tkwin2 == NULL) {
		return TCL_ERROR;
	    }
	    event.xmap.window = Tk_WindowId(tkwin2);
	} else if (strcmp(field, "-x") == 0) {
	    int rootX, rootY;
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    Tk_GetRootCoords(tkwin, &rootX, &rootY);
	    rootX += number;
	    if (flags & KEY_BUTTON_MOTION) {
		event.xkey.x = number;
		event.xkey.x_root = rootX;
	    } else if (flags & EXPOSE) {
		event.xexpose.x = number;
	    } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) {
		event.xcreatewindow.x = number;
	    } else if (flags & REPARENT) {
		event.xreparent.x = number;
	    } else if (flags & CROSSING) {
		event.xcrossing.x = number;
		event.xcrossing.x_root = rootY;
	    }
	} else if (strcmp(field, "-y") == 0) {
	    int rootX, rootY;
	    if (Tcl_GetInt(interp, value, &number) != TCL_OK) {
		return TCL_ERROR;
	    }
	    Tk_GetRootCoords(tkwin, &rootX, &rootY);
	    rootY += number;
	    if (flags & KEY_BUTTON_MOTION) {
		event.xkey.y = number;
		event.xkey.y_root = rootY;
	    } else if (flags & EXPOSE) {
		event.xexpose.y = number;
	    } else if (flags & (CREATE|CONFIG|GRAVITY|CONFIG_REQ)) {
		event.xcreatewindow.y = number;
	    } else if (flags & REPARENT) {
		event.xreparent.y = number;
	    } else if (flags & CROSSING) {
		event.xcrossing.y = number;
		event.xcrossing.y_root = rootY;
	    }
	} else {
	    Tcl_AppendResult(interp, "bad option \"", field, "\"",
		    (char *) NULL);
	    return TCL_ERROR;
	}
    }
    Tk_HandleEvent(&event);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestmakeexistCmd --
 *
 *	This procedure implements the "testmakeexist" command.  It calls
 *	Tk_MakeWindowExist on each of its arguments to force the windows
 *	to be created.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Forces windows to be created.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TestmakeexistCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Main window for application. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tk_Window main = (Tk_Window) clientData;
    int i;
    Tk_Window tkwin;

    for (i = 1; i < argc; i++) {
	tkwin = Tk_NameToWindow(interp, argv[i], main);
	if (tkwin == NULL) {
	    return TCL_ERROR;
	}
	Tk_MakeWindowExist(tkwin);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ImageCreate --
 *
 *	This procedure is called by the Tk image code to create "test"
 *	images.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	The data structure for a new image is allocated.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
ImageCreate(interp, name, argc, argv, typePtr, master, clientDataPtr)
    Tcl_Interp *interp;		/* Interpreter for application containing
				 * image. */
    char *name;			/* Name to use for image. */
    int argc;			/* Number of arguments. */
    char **argv;		/* Argument strings for options (doesn't
				 * include image name or type). */
    Tk_ImageType *typePtr;	/* Pointer to our type record (not used). */
    Tk_ImageMaster master;	/* Token for image, to be used by us in
				 * later callbacks. */
    ClientData *clientDataPtr;	/* Store manager's token for image here;
				 * it will be returned in later callbacks. */
{
    TImageMaster *timPtr;
    char *varName;
    int i;

    varName = "log";
    for (i = 0; i < argc; i += 2) {
	if (strcmp(argv[i], "-variable") != 0) {
	    Tcl_AppendResult(interp, "bad option name \"", argv[i],
		    "\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if ((i+1) == argc) {
	    Tcl_AppendResult(interp, "no value given for \"", argv[i],
		    "\" option", (char *) NULL);
	    return TCL_ERROR;
	}
	varName = argv[i+1];
    }
    timPtr = (TImageMaster *) ckalloc(sizeof(TImageMaster));
    timPtr->master = master;
    timPtr->interp = interp;
    timPtr->width = 30;
    timPtr->height = 15;
    timPtr->imageName = (char *) ckalloc((unsigned) (strlen(name) + 1));
    strcpy(timPtr->imageName, name);
    timPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
    strcpy(timPtr->varName, varName);
    Tcl_CreateCommand(interp, name, ImageCmd, (ClientData) timPtr,
	    (Tcl_CmdDeleteProc *) NULL);
    *clientDataPtr = (ClientData) timPtr;
    Tk_ImageChanged(master, 0, 0, 30, 15, 30, 15);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ImageCmd --
 *
 *	This procedure implements the commands corresponding to individual
 *	images.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Forces windows to be created.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
ImageCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Main window for application. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    TImageMaster *timPtr = (TImageMaster *) clientData;
    int x, y, width, height;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], "option ?arg arg ...?", (char *) NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "changed") == 0) {
	if (argc != 8) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " changed x y width height imageWidth imageHeight",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[4], &width) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[5], &height) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[6], &timPtr->width) != TCL_OK)
		|| (Tcl_GetInt(interp, argv[7], &timPtr->height) != TCL_OK)) {
	    return TCL_ERROR;
	}
	Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width,
		timPtr->height);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be changed", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ImageGet --
 *
 *	This procedure is called by Tk to set things up for using a
 *	test image in a particular widget.
 *
 * Results:
 *	The return value is a token for the image instance, which is
 *	used in future callbacks to ImageDisplay and ImageFree.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static ClientData
ImageGet(tkwin, clientData)
    Tk_Window tkwin;		/* Token for window in which image will
				 * be used. */
    ClientData clientData;	/* Pointer to TImageMaster for image. */
{
    TImageMaster *timPtr = (TImageMaster *) clientData;
    TImageInstance *instPtr;
    char buffer[100];
    XGCValues gcValues;

    sprintf(buffer, "%s get", timPtr->imageName);
    Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
	    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);

    instPtr = (TImageInstance *) ckalloc(sizeof(TImageInstance));
    instPtr->masterPtr = timPtr;
    instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000");
    gcValues.foreground = instPtr->fg->pixel;
    instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues);
    return (ClientData) instPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * ImageDisplay --
 *
 *	This procedure is invoked to redisplay part or all of an
 *	image in a given drawable.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The image gets partially redrawn, as an "X" that shows the
 *	exact redraw area.
 *
 *----------------------------------------------------------------------
 */

static void
ImageDisplay(clientData, display, drawable, imageX, imageY, width, height,
	drawableX, drawableY)
    ClientData clientData;	/* Pointer to TImageInstance for image. */
    Display *display;		/* Display to use for drawing. */
    Drawable drawable;		/* Where to redraw image. */
    int imageX, imageY;		/* Origin of area to redraw, relative to
				 * origin of image. */
    int width, height;		/* Dimensions of area to redraw. */
    int drawableX, drawableY;	/* Coordinates in drawable corresponding to
				 * imageX and imageY. */
{
    TImageInstance *instPtr = (TImageInstance *) clientData;
    char buffer[200];

    sprintf(buffer, "%s display %d %d %d %d %d %d",
	    instPtr->masterPtr->imageName, imageX, imageY, width, height,
	    drawableX, drawableY);
    Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
	    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
    if (width > (instPtr->masterPtr->width - imageX)) {
	width = instPtr->masterPtr->width - imageX;
    }
    if (height > (instPtr->masterPtr->height - imageY)) {
	height = instPtr->masterPtr->height - imageY;
    }
    XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY,
	    (unsigned) (width-1), (unsigned) (height-1));
    XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY,
	    (int) (drawableX + width - 1), (int) (drawableY + height - 1));
    XDrawLine(display, drawable, instPtr->gc, drawableX,
	    (int) (drawableY + height - 1),
	    (int) (drawableX + width - 1), drawableY);
}

/*
 *----------------------------------------------------------------------
 *
 * ImageFree --
 *
 *	This procedure is called when an instance of an image is
 * 	no longer used.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information related to the instance is freed.
 *
 *----------------------------------------------------------------------
 */

static void
ImageFree(clientData, display)
    ClientData clientData;	/* Pointer to TImageInstance for instance. */
    Display *display;		/* Display where image was to be drawn. */
{
    TImageInstance *instPtr = (TImageInstance *) clientData;
    char buffer[200];

    sprintf(buffer, "%s free", instPtr->masterPtr->imageName);
    Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
	    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
    Tk_FreeColor(instPtr->fg);
    Tk_FreeGC(display, instPtr->gc);
    ckfree((char *) instPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * ImageDelete --
 *
 *	This procedure is called to clean up a test image when
 *	an application goes away.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Information about the image is deleted.
 *
 *----------------------------------------------------------------------
 */

static void
ImageDelete(clientData)
    ClientData clientData;	/* Pointer to TImageMaster for image.  When
				 * this procedure is called, no more
				 * instances exist. */
{
    TImageMaster *timPtr = (TImageMaster *) clientData;
    char buffer[100];

    sprintf(buffer, "%s delete", timPtr->imageName);
    Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
	    TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);

    Tcl_DeleteCommand(timPtr->interp, timPtr->imageName);
    ckfree(timPtr->imageName);
    ckfree(timPtr->varName);
    ckfree((char *) timPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TestsendCmd --
 *
 *	This procedure implements the "testsend" command.  It provides
 *	a set of functions for testing the "send" command and support
 *	procedure in tkSend.c.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Depends on option;  see below.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TestsendCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Main window for application. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    TkWindow *winPtr = (TkWindow *) clientData;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
		" option ?arg ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

#ifndef WIN_TCL
    if (strcmp(argv[1], "bogus") == 0) {
	XChangeProperty(winPtr->dispPtr->display,
		RootWindow(winPtr->dispPtr->display, 0),
		winPtr->dispPtr->registryProperty, XA_INTEGER, 32,
		PropModeReplace,
		(unsigned char *) "This is bogus information", 6);
    } else if (strcmp(argv[1], "prop") == 0) {
	int result, actualFormat, length;
	unsigned long bytesAfter;
	Atom actualType, propName;
	char *property, *p, *end;
	Window w;

	if ((argc != 4) && (argc != 5)) {
	    Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
		    " prop window name ?value ?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (strcmp(argv[2], "root") == 0) {
	    w = RootWindow(winPtr->dispPtr->display, 0);
	} else if (strcmp(argv[2], "comm") == 0) {
	    w = Tk_WindowId(winPtr->dispPtr->commTkwin);
	} else {
	    w = strtoul(argv[2], &end, 0);
	}
	propName = Tk_InternAtom((Tk_Window) winPtr, argv[3]);
	if (argc == 4) {
	    property = NULL;
	    result = XGetWindowProperty(winPtr->dispPtr->display,
		    w, propName, 0, 100000, False, XA_STRING,
		    &actualType, &actualFormat, (unsigned long *) &length,
		    &bytesAfter, (unsigned char **) &property);
	    if ((result == Success) && (actualType != None)
		    && (actualFormat == 8) && (actualType == XA_STRING)) {
		for (p = property; (p-property) < length; p++) {
		    if (*p == 0) {
			*p = '\n';
		    }
		}
		Tcl_SetResult(interp, property, TCL_VOLATILE);
	    }
	    if (property != NULL) {
		XFree(property);
	    }
	} else {
	    if (argv[4][0] == 0) {
		XDeleteProperty(winPtr->dispPtr->display, w, propName);
	    } else {
		for (p = argv[4]; *p != 0; p++) {
		    if (*p == '\n') {
			*p = 0;
		    }
		}
		XChangeProperty(winPtr->dispPtr->display,
			w, propName, XA_STRING, 8, PropModeReplace,
			(unsigned char *) argv[4], p-argv[4]);
	    }
	}
    } else if (strcmp(argv[1], "serial") == 0) {
	sprintf(interp->result, "%d", tkSendSerial+1);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be bogus, prop, or serial", (char *) NULL);
	return TCL_ERROR;
    }
#endif
    return TCL_OK;
}