Initial revision

1 files changed, 1134 insertions, 0 deletions

diff --git a/generic/tkTest.c b/generic/tkTest.c
new file mode 100644
index 0000000..dab43d0
--- /dev/null
+++ b/generic/tkTest.c
@@ -0,0 +1,1134 @@
+/* 
+ * 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-1997 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.50 97/11/06 16:56:32
+ */
+
+#include "tkInt.h"
+#include "tkPort.h"	
+
+#ifdef __WIN32__
+#include "tkWinInt.h"
+#endif
+
+#ifdef MAC_TCL
+#include "tkScrollbar.h"
+#endif
+
+#ifdef __UNIX__
+#include "tkUnixInt.h"
+#endif
+
+/*
+ * 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[]));
+
+typedef struct CBinding {
+    Tcl_Interp *interp;
+    char *command;
+    char *delete;
+} CBinding;
+
+/*
+ * Forward declarations for procedures defined later in this file:
+ */
+
+static int		CBindingEvalProc _ANSI_ARGS_((ClientData clientData, 
+			    Tcl_Interp *interp, XEvent *eventPtr,
+			    Tk_Window tkwin, KeySym keySym));
+static void		CBindingFreeProc _ANSI_ARGS_((ClientData clientData));
+int			Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+static int		ImageCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+static int		TestcbindCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+#ifdef __WIN32__
+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		TestmakeexistCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+static int		TestmenubarCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+#if defined(__WIN32__) || defined(MAC_TCL)
+static int		TestmetricsCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+#endif
+static int		TestsendCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+static int		TestpropCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+#if !(defined(__WIN32__) || defined(MAC_TCL))
+static int		TestwrapperCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+#endif
+
+/*
+ * External (platform specific) initialization routine:
+ */
+
+EXTERN int		TkplatformtestInit _ANSI_ARGS_((
+			    Tcl_Interp *interp));
+#ifndef MAC_TCL
+#define TkplatformtestInit(x) TCL_OK
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 __WIN32__
+    Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+#endif
+    Tcl_CreateCommand(interp, "testcbind", TestcbindCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateCommand(interp, "testdeleteapps", TestdeleteappsCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateCommand(interp, "testembed", TkpTestembedCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateCommand(interp, "testmenubar", TestmenubarCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+#if defined(__WIN32__) || defined(MAC_TCL)
+    Tcl_CreateCommand(interp, "testmetrics", TestmetricsCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+#endif
+    Tcl_CreateCommand(interp, "testprop", TestpropCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateCommand(interp, "testsend", TestsendCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+#if !(defined(__WIN32__) || defined(MAC_TCL))
+    Tcl_CreateCommand(interp, "testwrapper", TestwrapperCmd,
+	    (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
+#endif
+
+/*
+     * Create test image type.
+     */
+
+    if (!initialized) {
+	initialized = 1;
+	Tk_CreateImageType(&imageType);
+    }
+
+    /*
+     * And finally add any platform specific test commands.
+     */
+    
+    return TkplatformtestInit(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 __WIN32__
+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
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestcbindCmd --
+ *
+ *	This procedure implements the "testcbinding" command.  It provides
+ *	a set of functions for testing C bindings in tkBind.c.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Depends on option;  see below.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestcbindCmd(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;
+    Tk_Window tkwin;
+    ClientData object;
+    CBinding *cbindPtr;
+    
+    
+    if (argc < 4 || argc > 5) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" bindtag pattern command ?deletecommand?", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    tkwin = (Tk_Window) clientData;
+
+    if (argv[1][0] == '.') {
+	winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
+	if (winPtr == NULL) {
+	    return TCL_ERROR;
+	}
+	object = (ClientData) winPtr->pathName;
+    } else {
+	winPtr = (TkWindow *) clientData;
+	object = (ClientData) Tk_GetUid(argv[1]);
+    }
+
+    if (argv[3][0] == '\0') {
+	return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable,
+		object, argv[2]);
+    }
+
+    cbindPtr = (CBinding *) ckalloc(sizeof(CBinding));
+    cbindPtr->interp = interp;
+    cbindPtr->command =
+	    strcpy((char *) ckalloc(strlen(argv[3]) + 1), argv[3]);
+    if (argc == 4) {
+	cbindPtr->delete = NULL;
+    } else {
+	cbindPtr->delete =
+		strcpy((char *) ckalloc(strlen(argv[4]) + 1), argv[4]);
+    }
+
+    if (TkCreateBindingProcedure(interp, winPtr->mainPtr->bindingTable,
+	    object, argv[2], CBindingEvalProc, CBindingFreeProc,
+	    (ClientData) cbindPtr) == 0) {
+	ckfree((char *) cbindPtr->command);
+	if (cbindPtr->delete != NULL) {
+	    ckfree((char *) cbindPtr->delete);
+	}
+	ckfree((char *) cbindPtr);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+static int
+CBindingEvalProc(clientData, interp, eventPtr, tkwin, keySym)
+    ClientData clientData;
+    Tcl_Interp *interp;
+    XEvent *eventPtr;
+    Tk_Window tkwin;
+    KeySym keySym;
+{
+    CBinding *cbindPtr;
+
+    cbindPtr = (CBinding *) clientData;
+    
+    return Tcl_GlobalEval(interp, cbindPtr->command);
+}
+
+static void
+CBindingFreeProc(clientData)
+    ClientData clientData;
+{
+    CBinding *cbindPtr = (CBinding *) clientData;
+    
+    if (cbindPtr->delete != NULL) {
+	Tcl_GlobalEval(cbindPtr->interp, cbindPtr->delete);
+	ckfree((char *) cbindPtr->delete);
+    }
+    ckfree((char *) cbindPtr->command);
+    ckfree((char *) cbindPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestmenubarCmd --
+ *
+ *	This procedure implements the "testmenubar" command.  It is used
+ *	to test the Unix facilities for creating space above a toplevel
+ *	window for a menubar.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Changes menubar related stuff.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static int
+TestmenubarCmd(clientData, interp, argc, argv)
+    ClientData clientData;		/* Main window for application. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+#ifdef __UNIX__
+    Tk_Window main = (Tk_Window) clientData;
+    Tk_Window tkwin, menubar;
+
+    if (argc < 2) {
+	Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
+		" option ?arg ...?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    if (strcmp(argv[1], "window") == 0) {
+	if (argc != 4) {
+	    Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
+		    "window toplevel menubar\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	tkwin = Tk_NameToWindow(interp, argv[2], main);
+	if (tkwin == NULL) {
+	    return TCL_ERROR;
+	}
+	if (argv[3][0] == 0) {
+	    TkUnixSetMenubar(tkwin, NULL);
+	} else {
+	    menubar = Tk_NameToWindow(interp, argv[3], main);
+	    if (menubar == NULL) {
+		return TCL_ERROR;
+	    }
+	    TkUnixSetMenubar(tkwin, menubar);
+	}
+    } else {
+	Tcl_AppendResult(interp, "bad option \"", argv[1],
+		"\": must be  window", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    return TCL_OK;
+#else
+    interp->result = "testmenubar is supported only under Unix";
+    return TCL_ERROR;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestmetricsCmd --
+ *
+ *	This procedure implements the testmetrics command. It provides
+ *	a way to determine the size of various widget components.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef __WIN32__
+static int
+TestmetricsCmd(clientData, interp, argc, argv)
+    ClientData clientData;		/* Main window for application. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    char buf[200];
+
+    if (argc < 2) {
+	Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
+		" option ?arg ...?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    if (strcmp(argv[1], "cyvscroll") == 0) {
+	sprintf(buf, "%d", GetSystemMetrics(SM_CYVSCROLL));
+	Tcl_AppendResult(interp, buf, (char *) NULL);
+    } else  if (strcmp(argv[1], "cxhscroll") == 0) {
+	sprintf(buf, "%d", GetSystemMetrics(SM_CXHSCROLL));
+	Tcl_AppendResult(interp, buf, (char *) NULL);
+    } else {
+	Tcl_AppendResult(interp, "bad option \"", argv[1],
+		"\": must be cxhscroll or cyvscroll", (char *) NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+#endif
+#ifdef MAC_TCL
+static int
+TestmetricsCmd(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 tkwin = (Tk_Window) clientData;
+    TkWindow *winPtr;
+    char buf[200];
+
+    if (argc != 3) {
+	Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
+		" option window\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin);
+    if (winPtr == NULL) {
+	return TCL_ERROR;
+    }
+    
+    if (strcmp(argv[1], "cyvscroll") == 0) {
+	sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width);
+	Tcl_AppendResult(interp, buf, (char *) NULL);
+    } else  if (strcmp(argv[1], "cxhscroll") == 0) {
+	sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width);
+	Tcl_AppendResult(interp, buf, (char *) NULL);
+    } else {
+	Tcl_AppendResult(interp, "bad option \"", argv[1],
+		"\": must be cxhscroll or cyvscroll", (char *) NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestpropCmd --
+ *
+ *	This procedure implements the "testprop" command.  It fetches
+ *	and prints the value of a property on a window.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static int
+TestpropCmd(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 result, actualFormat;
+    unsigned long bytesAfter, length, value;
+    Atom actualType, propName;
+    char *property, *p, *end;
+    Window w;
+    char buffer[30];
+
+    if (argc != 3) {
+	Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
+		" window property\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    w = strtoul(argv[1], &end, 0);
+    propName = Tk_InternAtom(main, argv[2]);
+    property = NULL;
+    result = XGetWindowProperty(Tk_Display(main),
+	    w, propName, 0, 100000, False, AnyPropertyType,
+	    &actualType, &actualFormat, &length,
+	    &bytesAfter, (unsigned char **) &property);
+    if ((result == Success) && (actualType != None)) {
+	if ((actualFormat == 8) && (actualType == XA_STRING)) {
+	    for (p = property; ((unsigned long)(p-property)) < length; p++) {
+		if (*p == 0) {
+		    *p = '\n';
+		}
+	    }
+	    Tcl_SetResult(interp, property, TCL_VOLATILE);
+	} else {
+	    for (p = property; length > 0; length--) {
+		if (actualFormat == 32) {
+		    value = *((long *) p);
+		    p += sizeof(long);
+		} else if (actualFormat == 16) {
+		    value = 0xffff & (*((short *) p));
+		    p += sizeof(short);
+		} else {
+		    value = 0xff & *p;
+		    p += 1;
+		}
+		sprintf(buffer, "0x%lx", value);
+		Tcl_AppendElement(interp, buffer);
+	    }
+	}
+    }
+    if (property != NULL) {
+	XFree(property);
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+    }
+
+#if !(defined(__WIN32__) || defined(MAC_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;
+	unsigned long length, 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, &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;
+}
+
+#if !(defined(__WIN32__) || defined(MAC_TCL))
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestwrapperCmd --
+ *
+ *	This procedure implements the "testwrapper" command.  It 
+ *	provides a way from Tcl to determine the extra window Tk adds
+ *	in between the toplevel window and the window decorations.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static int
+TestwrapperCmd(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, *wrapperPtr;
+    Tk_Window tkwin;
+
+    if (argc != 2) {
+	Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
+		" window\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    
+    tkwin = (Tk_Window) clientData;
+    winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
+    if (winPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    wrapperPtr = TkpGetWrapperWindow(winPtr);
+    if (wrapperPtr != NULL) {
+	TkpPrintWindowId(interp->result, Tk_WindowId(wrapperPtr));
+    }
+    return TCL_OK;
+}
+#endif