Import Upstream version 3.8.78.dfsg

1 files changed, 524 insertions, 0 deletions

diff --git a/tkSimple.c b/tkSimple.c
new file mode 100644
index 0000000..1cf0d13
--- /dev/null
+++ b/tkSimple.c
@@ -0,0 +1,524 @@
+/* 
+ *-----------------------------------------------------------------------
+ * tkSimple.c --
+ *
+ *   Implementation of a Very simple window which relies on C code for
+ *   almost all of its event handlers.
+ *
+ *-----------------------------------------------------------------------
+ */
+
+#ifdef TCL_WRAPPER
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <tk.h>
+/* 
+#include <tkInt.h>
+#include <tkIntDecls.h>     not portable! (jdk)  
+    this trick seems very broken on my machine so:
+declare this thing here, and hope the linker can resolve it
+*/
+EXTERN int		TkpUseWindow _ANSI_ARGS_((Tcl_Interp * interp, 
+				Tk_Window tkwin, CONST char * string));
+
+/* Backwards compatibility to tk8.3 and earlier */
+#if TK_MAJOR_VERSION == 8
+  #if TK_MINOR_VERSION <= 3
+    #define Tk_SetClassProcs(a,b,c) TkSetClassProcs(a,b,c)
+  #endif
+#endif
+
+#ifndef CONST84
+#define CONST84
+#endif
+
+/*
+ * A data structure of the following type is kept for each
+ * simple that currently exists for this process:
+ */
+
+typedef struct {
+    Tk_Window tkwin;		/* Window that embodies the simple.  NULL
+				 * means that the window has been destroyed
+				 * but the data structures haven't yet been
+				 * cleaned up. */
+    Display *display;		/* Display containing widget.  Used, among
+				 * other things, so that resources can be
+				 * freed even after tkwin has gone away. */
+    Tcl_Interp *interp;		/* Interpreter associated with widget.  Used
+				 * to delete widget command. */
+    Tcl_Command widgetCmd;	/* Token for simple's widget command. */
+    char *className;		/* Class name for widget (from configuration
+				 * option).  Malloc-ed. */
+    int width;			/* Width to request for window.  <= 0 means
+				 * don't request any size. */
+    int height;			/* Height to request for window.  <= 0 means
+				 * don't request any size. */
+    XColor *background;		/* background pixel used by XClearArea */
+    char *useThis;		/* If the window is embedded, this points to
+				 * the name of the window in which it is
+				 * embedded (malloc'ed).  For non-embedded
+				 * windows this is NULL. */
+    char *exitProc;		/* Callback procedure upon window deletion. */
+    char *commandProc;		/* Callback procedure for commands sent to the window */
+    char *mydata;		/* This space for hire. */
+    int flags;			/* Various flags;  see below for
+				 * definitions. */
+} Simple;
+
+/*
+ * Flag bits for simples:
+ *
+ * GOT_FOCUS:	non-zero means this widget currently has the input focus.
+ */
+
+#define GOT_FOCUS		1
+
+static Tk_ConfigSpec configSpecs[] = {
+    {TK_CONFIG_COLOR, "-background", "background", "Background",
+	"White", Tk_Offset(Simple, background), 0},
+    {TK_CONFIG_SYNONYM, "-bg", "background", (char *)NULL,
+	(char *)NULL, 0, 0},
+    {TK_CONFIG_PIXELS, "-height", "height", "Height",
+	"0", Tk_Offset(Simple, height), 0},
+    {TK_CONFIG_PIXELS, "-width", "width", "Width",
+	"0", Tk_Offset(Simple, width), 0},
+    {TK_CONFIG_STRING, "-use", "use", "Use",
+	"", Tk_Offset(Simple, useThis), TK_CONFIG_NULL_OK},
+    {TK_CONFIG_STRING, "-exitproc", "exitproc", "ExitProc",
+	"", Tk_Offset(Simple, exitProc), TK_CONFIG_NULL_OK},
+    {TK_CONFIG_STRING, "-commandproc", "commandproc", "CommandProc",
+	"", Tk_Offset(Simple, commandProc), TK_CONFIG_NULL_OK},
+    {TK_CONFIG_STRING, "-data", "data", "Data",
+	"", Tk_Offset(Simple, mydata), TK_CONFIG_NULL_OK},
+    {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
+	(char *) NULL, 0, 0}
+};
+
+/*
+ * Forward declarations for procedures defined later in this file:
+ */
+
+static int		ConfigureSimple _ANSI_ARGS_((Tcl_Interp *interp,
+			    Simple *simplePtr, int objc, Tcl_Obj *CONST objv[],
+			    int flags));
+static void		DestroySimple _ANSI_ARGS_((char *memPtr));
+static void		SimpleCmdDeletedProc _ANSI_ARGS_((
+			    ClientData clientData));
+static void		SimpleEventProc _ANSI_ARGS_((ClientData clientData,
+			    XEvent *eventPtr));
+static int		SimpleWidgetObjCmd _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_SimpleObjCmd --
+ *
+ *	This procedure is invoked to process the "simple"
+ *	Tcl command.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.  These procedures are just wrappers;
+ *	they call ButtonCreate to do all of the real work.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_SimpleObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Main window associated with
+				 * interpreter. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    Tk_Window tkwin = (Tk_Window) clientData;
+    Simple *simplePtr;
+    Tk_Window new;
+    char *arg, *useOption;
+    int i, c;  /* , depth; (jdk) */
+    size_t length;
+    unsigned int mask;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "pathName ?options?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Pre-process the argument list.  Scan through it to find any
+     * "-use" option, or the "-main" option.  If the "-main" option
+     * is selected, then the application will exit if this window
+     * is deleted.
+     */
+
+    useOption = NULL;
+    for (i = 2; i < objc; i += 2) {
+	arg = Tcl_GetStringFromObj(objv[i], (int *) &length);
+	if (length < 2) {
+	    continue;
+	}
+	c = arg[1];
+	if ((c == 'u') && (strncmp(arg, "-use", length) == 0)) {
+	    useOption = Tcl_GetString(objv[i+1]);
+	}
+    }
+
+    /*
+     * Create the window, and deal with the special option -use.
+     */
+
+    if (tkwin != NULL) {
+	new = Tk_CreateWindowFromPath(interp, tkwin, Tcl_GetString(objv[1]),
+		NULL);
+    }
+    if (new == NULL) {
+	goto error;
+    }
+    Tk_SetClass(new, "Simple");
+    if (useOption == NULL) {
+	useOption = (char *)Tk_GetOption(new, "use", "Use");
+    }
+    if (useOption != NULL) {
+	if (TkpUseWindow(interp, new, useOption) != TCL_OK) {
+	    goto error;
+	}
+    }
+
+    /*
+     * Create the widget record, process configuration options, and
+     * create event handlers.  Then fill in a few additional fields
+     * in the widget record from the special options.
+     */
+
+    simplePtr = (Simple *) ckalloc(sizeof(Simple));
+    simplePtr->tkwin = new;
+    simplePtr->display = Tk_Display(new);
+    simplePtr->interp = interp;
+    simplePtr->widgetCmd = Tcl_CreateObjCommand(interp,
+	    Tk_PathName(new), SimpleWidgetObjCmd,
+	    (ClientData) simplePtr, SimpleCmdDeletedProc);
+    simplePtr->className = NULL;
+    simplePtr->width = 0;
+    simplePtr->height = 0;
+    simplePtr->background = NULL;
+    simplePtr->useThis = NULL;
+    simplePtr->exitProc = NULL;
+    simplePtr->commandProc = NULL;
+    simplePtr->flags = 0;
+    simplePtr->mydata = NULL;
+
+    /*
+     * Store backreference to simple widget in window structure.
+     */
+    Tk_SetClassProcs(new, NULL, (ClientData) simplePtr);
+
+    /* We only handle focus and structure events, and even that might change. */
+    mask = StructureNotifyMask|FocusChangeMask|NoEventMask;
+    Tk_CreateEventHandler(new, mask, SimpleEventProc, (ClientData) simplePtr);
+
+    if (ConfigureSimple(interp, simplePtr, objc-2, objv+2, 0) != TCL_OK) {
+	goto error;
+    }
+    Tcl_SetResult(interp, Tk_PathName(new), TCL_STATIC);
+    return TCL_OK;
+
+    error:
+    if (new != NULL) {
+	Tk_DestroyWindow(new);
+    }
+    return TCL_ERROR;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * SimpleWidgetObjCmd --
+ *
+ *	This procedure is invoked to process the Tcl command
+ *	that corresponds to a simple widget.  See the user
+ *	documentation for details on what it does.  If the
+ *	"-commandProc" option has been set for the window,
+ *	then any unknown command (neither "cget" nor "configure")
+ *	will execute the command procedure first, then attempt
+ *	to execute the remainder of the command as an independent
+ *	Tcl command.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+SimpleWidgetObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Information about simple widget. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    static char *simpleOptions[] = {
+	"cget", "configure", (char *) NULL
+    };
+    enum options {
+	SIMPLE_CGET, SIMPLE_CONFIGURE
+    };
+    register Simple *simplePtr = (Simple *) clientData;
+    int result = TCL_OK, index;
+    size_t length;
+    int c, i;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[1],
+		(CONST84 char **)simpleOptions, "option", 0,
+		&index) != TCL_OK) {
+	if (simplePtr->commandProc != NULL) {
+	   Tcl_ResetResult(simplePtr->interp);
+	   if (Tcl_EvalEx(simplePtr->interp, simplePtr->commandProc, -1, 0)
+			!= TCL_OK)
+	      return TCL_ERROR;
+	   else
+	      return Tcl_EvalObjv(simplePtr->interp, --objc, ++objv, TCL_EVAL_DIRECT);
+	}
+	else
+	   return TCL_ERROR;
+    }
+    Tcl_Preserve((ClientData) simplePtr);
+    switch ((enum options) index) {
+      case SIMPLE_CGET: {
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "option");
+	    result = TCL_ERROR;
+	    goto done;
+	}
+	result = Tk_ConfigureValue(interp, simplePtr->tkwin, configSpecs,
+		(char *) simplePtr, Tcl_GetString(objv[2]), 0);
+	break;
+      }
+      case SIMPLE_CONFIGURE: {
+	if (objc == 2) {
+	    result = Tk_ConfigureInfo(interp, simplePtr->tkwin, configSpecs,
+		    (char *) simplePtr, (char *) NULL, 0);
+	} else if (objc == 3) {
+	    result = Tk_ConfigureInfo(interp, simplePtr->tkwin, configSpecs,
+		    (char *) simplePtr, Tcl_GetString(objv[2]), 0);
+	} else {
+	    for (i = 2; i < objc; i++) {
+		char *arg = Tcl_GetStringFromObj(objv[i], (int *) &length);
+		if (length < 2) {
+		    continue;
+		}
+		c = arg[1];
+		if ((c == 'u') && (strncmp(arg, "-use", length) == 0)) {
+		    Tcl_AppendResult(interp, "can't modify ", arg,
+			    " option after widget is created", (char *) NULL);
+		    result = TCL_ERROR;
+		    goto done;
+		}
+	    }
+	    result = ConfigureSimple(interp, simplePtr, objc-2, objv+2,
+		    TK_CONFIG_ARGV_ONLY);
+	}
+	break;
+      }
+    }
+
+    done:
+    Tcl_Release((ClientData) simplePtr);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DestroySimple --
+ *
+ *	This procedure is invoked by Tcl_EventuallyFree or Tcl_Release
+ *	to clean up the internal structure of a simple at a safe time
+ *	(when no-one is using it anymore).
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Everything associated with the simple is freed up.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DestroySimple(memPtr)
+    char *memPtr;		/* Info about simple widget. */
+{
+    register Simple *simplePtr = (Simple *) memPtr;
+
+    Tk_FreeOptions(configSpecs, (char *) simplePtr, simplePtr->display,
+	    TK_CONFIG_USER_BIT);
+    if (simplePtr->exitProc != NULL) {
+	/* Call the exit procedure */
+	Tcl_EvalEx(simplePtr->interp, simplePtr->exitProc, -1, 0);
+    }
+    ckfree((char *) simplePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConfigureSimple --
+ *
+ *	This procedure is called to process an objv/objc list, plus
+ *	the Tk option database, in order to configure (or
+ *	reconfigure) a simple widget.
+ *
+ * Results:
+ *	The return value is a standard Tcl result.  If TCL_ERROR is
+ *	returned, then the interp's result contains an error message.
+ *
+ * Side effects:
+ *	Configuration information, such as text string, colors, font,
+ *	etc. get set for simplePtr;  old resources get freed, if there
+ *	were any.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConfigureSimple(interp, simplePtr, objc, objv, flags)
+    Tcl_Interp *interp;		/* Used for error reporting. */
+    register Simple *simplePtr;	/* Information about widget;  may or may
+				 * not already have values for some fields. */
+    int objc;			/* Number of valid entries in objv. */
+    Tcl_Obj *CONST objv[];	/* Arguments. */
+    int flags;			/* Flags to pass to Tk_ConfigureWidget. */
+{
+  /* char *oldMenuName; (jdk) */
+    
+    if (Tk_ConfigureWidget(interp, simplePtr->tkwin, configSpecs,
+	    objc, (CONST84 char **) objv, (char *) simplePtr,
+	    flags | TK_CONFIG_OBJS) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    if ((simplePtr->width > 0) || (simplePtr->height > 0)) {
+	Tk_GeometryRequest(simplePtr->tkwin, simplePtr->width,
+		simplePtr->height);
+    }
+
+    if (simplePtr->background != NULL) {
+	Tk_SetWindowBackground(simplePtr->tkwin, simplePtr->background->pixel);
+    }
+
+    return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * SimpleEventProc --
+ *
+ *	This procedure is invoked by the Tk dispatcher on
+ *	structure changes to a simple.  For simples with 3D
+ *	borders, this procedure is also invoked for exposures.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	When the window gets deleted, internal structures get
+ *	cleaned up.  When it gets exposed, it is redisplayed.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+SimpleEventProc(clientData, eventPtr)
+    ClientData clientData;	/* Information about window. */
+    register XEvent *eventPtr;	/* Information about event. */
+{
+    register Simple *simplePtr = (Simple *) clientData;
+
+    if (eventPtr->type == DestroyNotify) {
+	if (simplePtr->tkwin != NULL) {
+
+	    /*
+	     * If this window is a container, then this event could be
+	     * coming from the embedded application, in which case
+	     * Tk_DestroyWindow hasn't been called yet.  When Tk_DestroyWindow
+	     * is called later, then another destroy event will be generated.
+	     * We need to be sure we ignore the second event, since the simple
+	     * could be gone by then.  To do so, delete the event handler
+	     * explicitly (normally it's done implicitly by Tk_DestroyWindow).
+	     */
+    
+	    Tk_DeleteEventHandler(simplePtr->tkwin,
+		    StructureNotifyMask | FocusChangeMask,
+		    SimpleEventProc, (ClientData) simplePtr);
+	    simplePtr->tkwin = NULL;
+            Tcl_DeleteCommandFromToken(simplePtr->interp, simplePtr->widgetCmd);
+	}
+	Tcl_EventuallyFree((ClientData) simplePtr, DestroySimple);
+    } else if (eventPtr->type == FocusIn) {
+	if (eventPtr->xfocus.detail != NotifyInferior) {
+	    simplePtr->flags |= GOT_FOCUS;
+	}
+    } else if (eventPtr->type == FocusOut) {
+	if (eventPtr->xfocus.detail != NotifyInferior) {
+	    simplePtr->flags &= ~GOT_FOCUS;
+	}
+    }
+    return;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SimpleCmdDeletedProc --
+ *
+ *	This procedure is invoked when a widget command is deleted.  If
+ *	the widget isn't already in the process of being destroyed,
+ *	this command destroys it.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The widget is destroyed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SimpleCmdDeletedProc(clientData)
+    ClientData clientData;	/* Pointer to widget record for widget. */
+{
+    Simple *simplePtr = (Simple *) clientData;
+    Tk_Window tkwin = simplePtr->tkwin;
+
+    /*
+     * This procedure could be invoked either because the window was
+     * destroyed and the command was then deleted (in which case tkwin
+     * is NULL) or because the command was deleted, and then this procedure
+     * destroys the widget.
+     */
+
+    if (tkwin != NULL) {
+	simplePtr->tkwin = NULL;
+	Tk_DestroyWindow(tkwin);
+    }
+}
+
+#endif /* TCL_WRAPPER */