/* *----------------------------------------------------------------------- * tkSimple.c -- * * Implementation of a Very simple window which relies on C code for * almost all of its event handlers. * *----------------------------------------------------------------------- */ #ifdef TCL_WRAPPER #include #include #include #include /* #include #include 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 */