diff options
Diffstat (limited to 'vendor/x11iraf/obm/server.c')
| -rw-r--r-- | vendor/x11iraf/obm/server.c | 3175 |
1 files changed, 3175 insertions, 0 deletions
diff --git a/vendor/x11iraf/obm/server.c b/vendor/x11iraf/obm/server.c new file mode 100644 index 00000000..fa46d2fd --- /dev/null +++ b/vendor/x11iraf/obm/server.c @@ -0,0 +1,3175 @@ +/* Copyright(c) 1993 Association of Universities for Research in Astronomy Inc. + */ + +#include <ObmP.h> + +/* The following internal files are needed for some widget level SmeBSB code + * included in this file. + */ +#include <X11/IntrinsicP.h> +#include <X11/Xaw/SmeBSBP.h> + +/* + * SERVER class. + * -------------------------- + * The server, or object manager, is the control center of the user interface. + * The server object provides a Tcl interpreter calling custom object manager + * commands. These are used to define and initialize the user interface, and + * execute UI action procedures at runtime. + * + * reset-server + * appInitialize appname, appclass, resources + * appExtend new-resources [overwrite] + * createObjects [resource-name] + * destroyObject object + * queryObject object [class [subclass]] + * activate + * deactivate [unmap] + * synchronize + * flush + * + * value = getResource resource-name [default-value [class]] + * getResources resource-list + * + * createMenu menu-name parent item-list + * editMenu menu-name parent item-list + * destroyMenu menu-name + * + * createBitmap name width height data + * createCursor name source mask fg_color bg_color x_hot y_hot + * createPixmap name width height depth fg_color bg_color data + * createXPixmap name widget description + * + * print arg [arg ...] # debug messages + * send object message + * + * postActivateCallback procedure + * postDeactivateCallback procedure + * + * id = postTimedCallback procedure msec [client-data] + * deleteTimedCallback id + * id = postWorkProc procedure [client-data] + * deleteWorkProc id + */ + +#define CB_WORKPROC 1 +#define CB_TIMER 2 + +/* Callback structure for timer, workproc callbacks. */ +struct _serverCallback { + XtPointer obj; + int callback_type; + char *userproc; + char *client_data; + union { + XtIntervalId intervalId; + XtWorkProcId workProcId; + } id; + struct _serverCallback *next; +}; +typedef struct _serverCallback serverCallback; +typedef struct _serverCallback *ServerCallback; + +struct serverPrivate { + ObmContext obm; + ServerCallback cb_head; + ServerCallback cb_tail; +}; + +typedef struct serverPrivate *ServerPrivate; + +struct serverObject { + struct obmObjectCore core; + struct serverPrivate server; +}; + +typedef struct serverObject *ServerObject; + +static ObmObject ServerCreate(); +static void ServerDestroy(); +static int ServerEvaluate(), serverQueryObject(); +static int serverCreateMenu(), serverDestroyMenu(); +static int serverAppInitialize(), serverAppExtend(), serverCreateObjects(); +static int serverSend(), serverPrint(), serverDestroyObject(); +static int serverReset(), serverActivate(), serverDeactivate(); +static int serverCreateBitmap(), serverCreatePixmap(), serverCreateCursor(); +static int serverPostActivateCallback(), serverPostDeactivateCallback(); +static int serverPostTimedCallback(), serverPostWorkProc(); +static int serverDeleteTimedCallback(), serverDeleteWorkProc(); +static int serverCreateXPixmap(), serverSynchronize(), serverFlush(); +static int serverGetResource(), serverGetResources(); +static void link_callback(), unlink_callback(); +static void serverTimedProc(); +static Boolean serverWorkProc(); + +static int editMenu(); +static void menu_popup(), menu_popdown(), menu_popdown_msgHandler(); +static void createMenu(), menuSelect(), build_colorlist(); +static void menu_classInit(), menu_addEntry(), menu_delEntry(); +static void menu_highlight(), menu_unhighlight(); +static Pixmap menu_pullrightBitmap(); +static MenuPtr findMenu(); +extern long strtol(); + +/* The pull-right bitmap for menus. */ +#define MB_WIDTH 16 +#define MB_HEIGHT 16 +#define MB1_PIXELS \ + "0x00, 0x00, 0x30, 0x00, 0xf0, 0x00, 0xf0, 0x03, 0xf0, 0x0f, 0xf0, 0x0f,\ + 0xf0, 0x03, 0xf0, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00" +#define MB2_PIXELS \ + "0x00, 0x00, 0x30, 0x00, 0xd0, 0x00, 0x10, 0x03, 0x10, 0x0c, 0x10, 0x0c,\ + 0x10, 0x03, 0xd0, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,\ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00" + + +/* ServerClassInit -- Initialize the class record for the server class. + */ +void +ServerClassInit (obm, classrec) +ObmContext obm; +register ObjClassRec classrec; +{ + classrec->ClassDestroy = obmGenericClassDestroy; + classrec->Create = (ObmFunc) ServerCreate; + classrec->Destroy = ServerDestroy; + classrec->Evaluate = ServerEvaluate; +} + + +/* ServerCreate -- Create an instance of a server object. + */ +static ObmObject +ServerCreate (obm, name, classrec, parent, args, nargs) +ObmContext obm; +char *name; +ObjClassRec classrec; +char *parent; +ArgList args; +int nargs; +{ + register ServerObject obj; + register Tcl_Interp *tcl; + + obj = (ServerObject) XtCalloc (1, sizeof (struct serverObject)); + obm->tcl = tcl = Tcl_CreateInterp(); + obj->server.obm = obm; + + /* Register server actions. */ + Tcl_CreateCommand (tcl, + "reset-server", serverReset, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "activate", serverActivate, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "deactivate", serverDeactivate, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "synchronize", serverSynchronize, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "flush", serverFlush, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "postActivateCallback", serverPostActivateCallback, + (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "postDeactivateCallback", serverPostDeactivateCallback, + (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "appInitialize", serverAppInitialize, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "appExtend", serverAppExtend, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "createObjects", serverCreateObjects, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "destroyObject", serverDestroyObject, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "queryObject", serverQueryObject, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "send", serverSend, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "print", serverPrint, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "getResource", serverGetResource, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "getResources", serverGetResources, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "postTimedCallback", serverPostTimedCallback, + (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "deleteTimedCallback", serverDeleteTimedCallback, + (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "postWorkProc", serverPostWorkProc, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "deleteWorkProc", serverDeleteWorkProc, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "createBitmap", serverCreateBitmap, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "createPixmap", serverCreatePixmap, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "createXPixmap", serverCreateXPixmap, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "createCursor", serverCreateCursor, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "createMenu", serverCreateMenu, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "editMenu", serverCreateMenu, (ClientData)obj, NULL); + Tcl_CreateCommand (tcl, + "destroyMenu", serverDestroyMenu, (ClientData)obj, NULL); + + return ((ObmObject) obj); +} + + +/* ServerDestroy -- Destroy an instance of a server object. + */ +static void +ServerDestroy (object) +ObmObject object; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + register ServerCallback cb, next; + + /* Destroy the object in the second final call to Destroy. */ + if (!obj->core.being_destroyed++) + return; + + /* Delete any pending timers or work procs. */ + for (cb = obj->server.cb_head; cb; cb = next) { + next = cb->next; + switch (cb->callback_type) { + case CB_TIMER: + XtRemoveTimeOut (cb->id.intervalId); + break; + case CB_WORKPROC: + XtRemoveWorkProc (cb->id.workProcId); + break; + } + XtFree ((char *)cb); + } + + obj->server.cb_head = NULL; + obj->server.cb_tail = NULL; + + /* Destroy the server interpreter. */ + if (obm->tcl) { + Tcl_DeleteInterp (obm->tcl); + obm->tcl = NULL; + } +} + + +/* ServerEvaluate -- Evaluate a server command or message. + */ +static int +ServerEvaluate (object, command) +ObmObject object; +char *command; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + static char reset[] = "reset-server"; + register char *ip; + + /* The command "reset-server" is a special case. This destroys the + * current user interface including all objects and widgets. One + * of the objects destroyed is the server object including the tcl + * interpreter. We can't use a normal Tcl command to implement this + * as the server and Tcl data structures will be freed and the rest + * of the input command would be lost. Instead, we check for the + * reset-server command, which must be the first command in the input + * command string, and manually reset things then call Tcl to process + * the remainder of the input command. The reset-server command should + * be the first command in the server config file used to define the + * user interface for a new application. Comments and blank lines + * at the head of the file are ignored. + */ + for (ip=command; *ip; ) { + while (isspace (*ip)) + ip++; + if (*ip == '#') + while (*ip && *ip != '\n') + ip++; + if (isspace (*ip)) + ip++; + else + break; + } + if (strncmp (ip, reset, strlen(reset)) == 0) { + ObmInitialize (obm); + obj = (ServerObject) obmFindObject (obm, "Server"); + } + + /* Now interpret the full message using Tcl. This re-executes the + * reset-server command, which will be ignored since this is a no-op + * when it occurs within a script. We want to leave the command in + * the script as otherwise the line numbers won't be correct. + */ + return (Tcl_Eval (obm->tcl, command)); +} + + +/* serverAppInitialize -- TCL command to initialize the server for a new + * application, setting the application name and loading the application + * resources. + * + * Usage: appInitialize appname, appclass, resources + */ +static int +serverAppInitialize (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + register ObmCallback cb; + + char *resource_buf, *resource_list[MAX_RESOURCES]; + char *appname, *appclass, *resources; + int sv_argc, nresources; + char **sv_argv; + char *ip, *op; + + /* Get arguments. */ + if (argc >= 2) { + strcpy (obm->appname, appname = argv[1]); + strcpy (obm->appclass, appclass = argv[2]); + } else { + appname = "gterm-iraf"; + appclass = "Xgterm"; + } + + if (argc >= 3) + resources = argv[3]; + else + resources = ""; + + /* Get fallback resources. */ + resource_buf = op = XtMalloc (strlen(resources) + MAX_RESOURCES); + resource_list[0] = op; + nresources = 0; + + for (ip=resources; *ip; ip++) { + while (*ip && (*ip == ' ' || *ip == '\t')) + ip++; + if (*ip == '\n') { + ; + } else if (*ip == '!') { + while (*ip && *ip != '\n') + ip++; + } else { + while (*ip && *ip != '\n') + *op++ = *ip++; + *op++ = '\0'; + nresources++; + resource_list[nresources] = op; + } + } + *op++ = '\0'; + resource_list[nresources] = NULL; + + /* Set fallback resources. */ + XtAppSetFallbackResources (obm->app_context, resource_list); + + /* Get local copy of argc and argv. */ + if ((sv_argc = obm->argc) > 0) { + sv_argv = (char **) XtMalloc (obm->argc * sizeof(char *)); + memmove (sv_argv, obm->argv, obm->argc * sizeof(char *)); + } else + sv_argv = obm->argv; + + /* Open the display (initializes the resource database). A separate + * display descriptor is used so that we can specify the application + * name, class, and resources independently from those of the + * application using the object manager. + */ + obm->display = XtOpenDisplay (obm->app_context, (String)NULL, + appname, appclass, NULL, 0, &sv_argc, sv_argv); + if (obm->display == (Display *)NULL) + XtAppError (obm->app_context, "appInitialize: Can't open display."); + + if (obm->debug > 1) + XSynchronize (obm->display, True); + + /* Create the top level shell. */ + obm->toplevel = XtAppCreateShell (appname, appclass, + applicationShellWidgetClass, obm->display, (ArgList)NULL, 0); + obm->screen = XtScreen (obm->toplevel); + + /* Call the client's display connection callback if any. */ + for (cb = obm->callback_list; cb; cb = cb->next) + if ((cb->callback_type & OBMCB_connect) && cb->u.fcn) + (*cb->u.fcn) (cb->client_data, obm->display, obm->toplevel, 1); + + /* Add the toplevel shell to the application's object list. */ + obmNewObject (obm, "toplevel", "TopLevelShell", NULL, NULL, 0); + + if (obm->argc > 0) + XtFree ((char *)sv_argv); + XtFree ((char *)resource_buf); + XtAppSetFallbackResources (obm->app_context, NULL); + + obm->specified++; + return (TCL_OK); +} + + +/* serverAppExtend -- TCL command to extend the application resource database + * to allow for the creation of new widgets loaded since the application was + * first started. The 'overwrite' option, if present, says to allow the new + * resource strings to overwrite the existing resources, otherwise the older + * ones will not be changed. + * + * Usage: appExtend new-resources [overwrite] + */ +static int +serverAppExtend (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + XrmDatabase old_db, extended_db; + Boolean overwrite = False; + char *resources; + + + if (!obm->specified || !obm->display || argc < 2) + return (TCL_ERROR); + + /* Get arguments. */ + resources = argv[1]; + overwrite = (argc > 2) ? (strcmp (argv[2], "overwrite") == 0) : False; + + /* Get the current fallback resource database. */ + old_db = XrmGetDatabase (obm->display); + if (old_db == (XrmDatabase) NULL) + return (TCL_ERROR); + + /* Create a database structure from the resource string. */ + extended_db = XrmGetStringDatabase (resources); + if (extended_db == (XrmDatabase) NULL) + return (TCL_ERROR); + + /* Combine the old an new databases. */ + XrmCombineDatabase (extended_db, &old_db, overwrite); + + /* Update the application resource database. */ + XrmSetDatabase (obm->display, old_db); + + return (TCL_OK); +} + + +/* serverCreateObjects -- TCL command to create the tree of UI objects + * comprising the user interface. The object tree is defined by a string + * valued resource. If no resource is named the default "objects" resource + * will be used. + * + * Usage: createObjects [resource-name] + */ +static int +serverCreateObjects (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register char *ip, *op; + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + char name[SZ_NAME], class[SZ_NAME], parent[SZ_NAME]; + char *objects = NULL; + XtResource r; + + r.resource_name = (argc >= 2) ? argv[1] : "objects"; + r.resource_class = "Objects"; + r.resource_type = XtRString; + r.resource_size = sizeof (char *); + r.resource_offset = 0; + r.default_type = XtRString; + r.default_addr = (caddr_t) NULL; + + /* Get the UI object list. */ + XtGetApplicationResources (obm->toplevel, &objects, &r, 1, NULL, 0); + /* XrmPutFileDatabase (obm->display->db, "zz.list"); */ + + /* Parse the objects list and create the objects. Each entry has + * the form "parent object-class object-name" with a newline (or + * other whitespace) terminating each entry. + */ + for (ip = objects; ip && *ip; ) { + /* Get name of parent object. */ + while (isspace (*ip)) + ip++; + for (op=parent; *ip && !isspace(*ip); ) + *op++ = *ip++; + *op = '\0'; + + /* Get object class. */ + while (isspace (*ip)) + ip++; + for (op=class; *ip && !isspace(*ip); ) + *op++ = *ip++; + *op = '\0'; + + /* Get object name. */ + while (isspace (*ip)) + ip++; + for (op=name; *ip && !isspace(*ip); ) + *op++ = *ip++; + *op = '\0'; + + /* Create the new object. */ + if (*name && *class && *parent) + obmNewObject (obm, name, class, parent, NULL, 0); + + while (isspace (*ip)) + ip++; + } + + return (TCL_OK); +} + + +/* serverDestroyObject -- Destroy an object and all of its children. + * + * Usage: destroyObject object-name + */ +static int +serverDestroyObject (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + char *object_name; + ObmObject killobj; + + if (argc < 2) + return (TCL_ERROR); + + object_name = argv[1]; + if ((killobj = obmFindObject (obm, object_name)) == NULL) + return (TCL_ERROR); + obmDestroyObject (obm, killobj); + + return (TCL_OK); +} + + +/* serverQueryObject -- Test if the named object exists. + * + * Usage: queryObject object-name [class [subclass]] + * + * A nonzero function value is returned if the named object exists. The + * class and subclass of the object are optionally returned in the output + * variables given on the command line. + */ +static int +serverQueryObject (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + char *object_name, *s_class, *s_subclass; + ObjClassRec classrec; + ObmObject o; + + if (argc < 2) + return (TCL_ERROR); + + object_name = argv[1]; + s_class = (argc > 2) ? argv[2] : NULL; + s_subclass = (argc > 3) ? argv[3] : NULL; + + if (o = obmFindObject (obm, object_name)) { + classrec = o->core.classrec; + if (s_class) { + BaseClassRec bp; + int i; + + for (i=0; i < OtNClasses; i++) { + bp = &baseClasses[i]; + if (bp->class == classrec->object_type) { + Tcl_SetVar (obm->tcl, s_class, bp->name, 0); + break; + } + } + } + if (s_subclass) + Tcl_SetVar (obm->tcl, s_subclass, + (classrec->object_type == OtShell) ? + "Shell" : classrec->name, 0); + + Tcl_SetResult (obm->tcl, TRUESTR, TCL_STATIC); + } else + Tcl_SetResult (obm->tcl, FALSESTR, TCL_STATIC); + + return (TCL_OK); +} + + +/* serverActivate -- Activate the user interface. When called the first + * time the user interface is created and activated, thereafter the UI is + * merely reactivated (e.g. mapped if unmapped). + * + * Usage: activate + */ +static int +serverActivate (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + XWMHints hints; + register int i; + ObmObject child; + Widget w; + + + /* Activate the interface. */ + ObmActivate (obm); + + + /* Now set the WM hints for the toplevel shell and any subwindows + * of the UI. Certain ICCCM-compliant window managers make assumptions + * about how the client windows will handle input focus if it's not + * set explicitly, and often the UI is not given the focus. + */ + hints.flags = InputHint | StateHint; + hints.input = True; + hints.initial_state = NormalState; + hints.icon_pixmap = None; + hints.icon_window = None; + hints.icon_x = hints.icon_y = 0; + hints.icon_mask = None; + hints.window_group = None; + + XSetWMHints(obm->display, XtWindow(obm->toplevel), &hints); + + obj = (ServerObject) obmFindObject (obm, "toplevel"); + for (i=0; i < obj->core.nchildren; i++) { + child = obj->core.children[i]; + if (child->core.classrec->object_type == OtShell) { + w = widgetGetPointer (child); + XSetWMHints(obm->display, XtWindow(w), &hints); + } + } + + return (TCL_OK); +} + + +/* serverDeactivate -- Deactivate the user interface. Optionally unmaps the + * UI and calls the Obm client back to let it know that the UI has been + * deactivated. + * + * Usage: deactivate [unmap] + */ +static int +serverDeactivate (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + + ObmDeactivate (obm, argc >=2 && strcmp(argv[1],"unmap") == 0); + return (TCL_OK); +} + + +/* serverSynchronize -- Synchronize the user interface. + * + * Usage: synchronize + * + * Any buffered output to the display is flushed and execution pauses until + * the display has caught up. It is rarely necessary to sychronize the + * display with the client and this defeats the purpose of command buffering, + * hence should be done only when necessary. Try "flush" below first. + */ +static int +serverSynchronize (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + + XSync (obm->display, False); + while (XtAppPending (obm->app_context)) + XtAppProcessEvent (obm->app_context, XtIMAll); + + return (TCL_OK); +} + + +/* serverFlush -- Flush output to the user interface. + * + * Usage: flush + * + * Any buffered output to the display is flushed to the display and + * execution continues. + */ +static int +serverFlush (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + + XFlush (obm->display); + + return (TCL_OK); +} + + +/* serverPostActivateCallback -- Post a callback procedure to be called + * when the UI is activated. The UI is activated when it is first + * downloaded to server, but it may also be activated (reactivated) after + * the application has exited and is later restarted, or when the UI + * is deactivated and reactivated. Note that the UI state vis-a-vis the + * external world (client application) may no longer be accurate after + * it has been idle for a time and then reactivated. + * + * Usage: postActivateCallback <procedure> + */ +static int +serverPostActivateCallback (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + register ObmCallback cb; + + if (argc < 2) + return (TCL_ERROR); + if (!(cb = obmAddCallback (&obm->callback_list))) + return (TCL_ERROR); + + cb->callback_type = OBMUI_activate; + strncpy (cb->name, argv[1], SZ_NAME); + + return (TCL_OK); +} + + +/* serverPostDeactivateCallback -- Post a callback procedure to be called + * when the UI is deactivated. + * + * Usage: postDeactivateCallback <procedure> + */ +static int +serverPostDeactivateCallback (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + register ObmCallback cb; + + if (argc < 2) + return (TCL_ERROR); + if (!(cb = obmAddCallback (&obm->callback_list))) + return (TCL_ERROR); + + cb->callback_type = OBMUI_deactivate; + strncpy (cb->name, argv[1], SZ_NAME); + + return (TCL_OK); +} + + +/* serverSend -- Send a message to an object. The object interprets the + * message and returns a function value as the string result of the TCL + * command. + * + * Usage: send <object> <message> + */ +static int +serverSend (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + int status; + + /* The object which interprets the message leaves the string result, + * if any, directly in the server tcl result string. + */ + if (argc == 3) + status = ObmDeliverMsg (obm, argv[1], argv[2]); + else { + char *message = Tcl_Merge (argc-2, &argv[2]); + status = ObmDeliverMsg (obm, argv[1], message); + free ((char *)message); + } + + return (status); +} + + +/* serverPrint -- Print a string on the standard output. This is used mainly + * for debugging user interfaces. + * + * Usage: print arg [arg ...] + */ +static int +serverPrint (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + + if (argc >= 2) { + char *message = Tcl_Concat (argc-1, &argv[1]); + printf ("%s\n", message); + fflush (stdout); + free ((char *)message); + } + + return (TCL_OK); +} + + +/* serverReset -- The "reset-server" command is implemented as a special + * case in ServerEvaluate. After doing a true reset ServerEvaluate calls + * Tcl_Eval to evaluate the full message which still contains the reset-server + * command. We want to ignore this the second time, so we treat the command + * here as a no-op. + * + * Usage: reset-server + * + * Note: for reset-server to be recognized by ServerEvaluate and really reset + * things, it must be the first command in a message to the server. + */ +static int +serverReset (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + return (TCL_OK); +} + + +/* serverGetResource -- Get the string value of the specified application + * resource (window system parameter). This allows use of the resource + * mechanism to supply default values for GUI parameters. + * + * Usage: value = getResource resource-name [class [default-value]] + * + * In the simplest case one merely requests a resource by name and the + * string value is returned as the function value. If the resource has + * an entry in the fallback resources for the application (appInitialize + * resource list) then a value is guaranteed to be returned. + * + * If the Class name for the resource is given then a class default value + * will be returned if no entry is found for the name resource instance. + * This is useful when there are a number of resources of the same type + * (same class). If most or all resources in the same class have the same + * default value one need only make one entry for the Class in the application + * defaults resource list. It is up to the application developer to define + * the class name of a resource - the class name can be any string. Examples + * are "Font", "Cursor", etc. By convention the first character of a class + * name is capitalized, while instance names begin with a lower case letter. + * + * If there is an entry for the named resource in the resource list passed + * to appInitialize then a value string is guaranteed to be returned. This + * will be either the appInitialize default, or a value specified by the + * system or the user in an X resources file. If one is not certain a + * default value is defined somewhere, a default value should be specified + * in the getResource call as shown above. + * + * See also getResources, used to get multiple resources in one call. + */ +static int +serverGetResource (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + char *resource_name, *class_name, *default_value; + char *value = NULL; + XtResource r; + + if (argc < 2) + return (TCL_ERROR); + + resource_name = argv[1]; + class_name = (argc > 2) ? argv[2] : XtCString; + default_value = (argc > 3) ? argv[3] : ""; + + r.resource_name = resource_name; + r.resource_class = class_name; + r.resource_type = XtRString; + r.resource_size = sizeof (char *); + r.resource_offset = 0; + r.default_type = XtRString; + r.default_addr = (caddr_t) default_value; + + XtGetApplicationResources (obm->toplevel, &value, &r, 1, NULL, 0); + Tcl_SetResult (tcl, value, TCL_VOLATILE); + + return (TCL_OK); +} + + +/* serverGetResources -- Get the string values of a list of resources. + * + * Usage: getResources resource-list + * e.g. + * getResources { + * { resource [variable class [default-value]]] } + * { resource [variable class [default-value]]] } + * (etc.) + * } + * + * The resource list is a list of resource descriptions. Each resource + * entry must give at least the resource name. If no Tcl variable is named + * the resource name will be used and this variable will be set to the + * resource value. The class name and default value fields are optional. + */ +static int +serverGetResources (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + register XtResource *r; + XtResource resources[MAX_RESOURCES]; + char *resource_name, *class_name, *default_value; + char *resource_list, *variable; + char **items, **fields; + int nitems, nfields; + char buf[SZ_NUMBER]; + int item, i; + + typedef struct { + char *variable; + char *value; + char *item_list; + } Value; + Value values[MAX_RESOURCES]; + + if (argc < 2) { + tcl->result = "missing resource-list argument"; + return (TCL_ERROR); + } else + resource_list = argv[1]; + + if (Tcl_SplitList (tcl, resource_list, &nitems, &items) != TCL_OK) { + tcl->result = "could not parse resource list"; + return (TCL_ERROR); + } else if (nitems > MAX_MENUITEMS) + nitems = MAX_MENUITEMS; + + for (item=0; item < nitems; item++) { + if (Tcl_SplitList (tcl, items[item], &nfields, &fields) != TCL_OK) { +err: sprintf (buf, "bad item '%d' in resource list", item + 1); + Tcl_AppendResult (tcl, buf, NULL); + for (i=0; i < item; i++) + free (values[item].item_list); + return (TCL_ERROR); + } + + if (nfields < 1) + goto err; + + resource_name = fields[0]; + variable = (nfields > 1) ? fields[1] : fields[0]; + class_name = (nfields > 2) ? fields[2] : XtCString; + default_value = (nfields > 3) ? fields[3] : ""; + + r = &resources[item]; + r->resource_name = resource_name; + r->resource_class = class_name; + r->resource_type = XtRString; + r->resource_size = sizeof (char *); + r->resource_offset = (unsigned int) &(((Value *)NULL)[item].value); + r->default_type = XtRString; + r->default_addr = (caddr_t) default_value; + + values[item].variable = variable; + values[item].item_list = (char *) fields; + } + + XtGetApplicationResources (obm->toplevel, + (XtPointer) values, resources, nitems, NULL, 0); + + for (item=0; item < nitems; item++) { + if (Tcl_SetVar (tcl, + values[item].variable, values[item].value, 0) == NULL) { + fprintf (stderr, + "Warning (getResources): cannot set value of %s\n", + values[item].variable); + } + free (values[item].item_list); + } + free ((char *) items); + + return (TCL_OK); +} + + +/* serverPostTimedCallback -- Post a callback to call the named procedure + * back after a specified delay in milliseconds. + * + * Usage: id = postTimedCallback procedure msec [client-data] + * + * After the specified delay the user callback procedure will be called + * with client_data (if given) as the single argument. Only one call will + * be made; the client must repost the callback in each call if the procedure + * is to be repeatedly executed. + * + * An ID value is returned which may be passed to deleteTimedCallback to + * delete the timer. If a zero or negative time interval is requested no + * timer will be set and zero will be returned as the timer ID. + * + */ +static int +serverPostTimedCallback (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + char *userproc, *client_data; + unsigned long interval; + char buf[SZ_NUMBER]; + ServerCallback cb; + int nchars; + + if (argc < 3) + return (TCL_ERROR); + + /* Get arguments. */ + userproc = argv[1]; + interval = atoi (argv[2]); + client_data = (argc > 3) ? argv[3] : NULL; + + if (interval > 0) { + /* Allocate and initialize the callback structure. */ + nchars = sizeof(serverCallback) + strlen(userproc)+1 + + (client_data ? strlen(client_data)+1 : 0); + if (!(cb = (ServerCallback) XtCalloc (nchars,1))) + return (TCL_ERROR); + + cb->obj = (XtPointer) obj; + cb->userproc = (char *)cb + sizeof(serverCallback); + cb->client_data = client_data ? + cb->userproc+strlen(userproc)+1 : NULL; + cb->callback_type = CB_TIMER; + cb->next = NULL; + + strcpy (cb->userproc, userproc); + if (client_data) + strcpy (cb->client_data, client_data); + + cb->id.intervalId = XtAppAddTimeOut (obm->app_context, + interval, serverTimedProc, (XtPointer)cb); + link_callback (&obj->server, cb); + } else + cb = NULL; + + sprintf (buf, "0x%lx", cb); + Tcl_SetResult (tcl, buf, TCL_VOLATILE); + + return (TCL_OK); +} + + +/* serverTimedProc -- Xt callback procedure for interval timers. + */ +static void +serverTimedProc (cb_ptr, id) +XtPointer cb_ptr; +XtIntervalId *id; +{ + register ServerCallback cb = (ServerCallback) cb_ptr; + register ServerObject obj = (ServerObject) cb->obj; + ObmContext obm = obj->server.obm; + int status; + + status = Tcl_VarEval (obm->tcl, + cb->userproc, " ", + cb->client_data ? cb->client_data : " ", + NULL); + if (status != TCL_OK) { + char *errstr = Tcl_GetVar (obm->tcl, "errorInfo", 0); + fprintf (stderr, "Error on line %d in %s: %s\n", + obm->tcl->errorLine, cb->userproc, + errstr ? errstr : obm->tcl->result); + } + + unlink_callback (&obj->server, cb); +/* XtFree ((char *)cb);*/ +} + + +/* serverDeleteTimedCallback -- Delete a timer callback procedure. This + * procedure is typically used to break a timer loop, where the timer + * procedure repeatedly reposts itself at the end of each interval. + * + * Usage: deleteTimedCallback id + * + * The ID string is returned by postTimedCallback when a timer is posted. + */ +static int +serverDeleteTimedCallback (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + ServerCallback cb; + XtIntervalId id; + + if (argc < 2) + return (TCL_ERROR); + + if (cb = (ServerCallback) strtol (argv[1], (char **)NULL, 16)) { + XtRemoveTimeOut (cb->id.intervalId); + unlink_callback (&obj->server, cb); + XtFree ((char *)cb); + } + return (TCL_OK); +} + + +/* serverPostWorkProc -- Post a callback for a procedure to be called when + * the server is idle. Work procedures are used to perform computations in + * the background while the user interface remains active and able to respond + * to input events. This works only if the user work procedure does its job + * in small increments, doing only a small amount of processing in each call. + * The work procedure will be called repeatedly until it returns a status + * indicating that it has finished its task. + * + * Usage: id = postWorkProc procedure [client-data] + * + * When the server has nothing else to do the user work procedure will be + * called with client_data (if given) as the single argument. The work + * procedure should return the string "done" when all processing is finished, + * or any other string if the procedure is to be called again. + * + * An ID value is returned which may be passed to deleteWorkProc to + * delete the work procedure. + */ +static int +serverPostWorkProc (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + register ObmContext obm = obj->server.obm; + char *userproc, *client_data; + char buf[SZ_NUMBER]; + ServerCallback cb; + int nchars; + + if (argc < 2) + return (TCL_ERROR); + + /* Get arguments. */ + userproc = argv[1]; + client_data = (argc > 2) ? argv[2] : NULL; + + /* Allocate and initialize the callback structure. */ + nchars = sizeof(serverCallback) + strlen(userproc)+1 + + (client_data ? strlen(client_data)+1 : 0); + if (!(cb = (ServerCallback) XtMalloc (nchars))) + return (TCL_ERROR); + + cb->obj = (XtPointer) obj; + cb->userproc = (char *)cb + sizeof(serverCallback); + cb->client_data = client_data ? cb->userproc+strlen(userproc)+1 : NULL; + cb->callback_type = CB_WORKPROC; + cb->next = NULL; + + strcpy (cb->userproc, userproc); + if (client_data) + strcpy (cb->client_data, client_data); + + cb->id.workProcId = XtAppAddWorkProc (obm->app_context, + serverWorkProc, (XtPointer)cb); + link_callback (&obj->server, cb); + + sprintf (buf, "0x%lx", cb); + Tcl_SetResult (tcl, buf, TCL_VOLATILE); + + return (TCL_OK); +} + + +/* serverWorkProc -- Xt callback procedure for work procedures. + */ +static Boolean +serverWorkProc (cb_ptr) +XtPointer cb_ptr; +{ + register ServerCallback cb = (ServerCallback) cb_ptr; + register ServerObject obj = (ServerObject) cb->obj; + register ObmContext obm = obj->server.obm; + Boolean done; + int status; + + status = Tcl_VarEval (obm->tcl, + cb->userproc, " ", + cb->client_data ? cb->client_data : " ", + NULL); + + if (status != TCL_OK) { + char *errstr = Tcl_GetVar (obm->tcl, "errorInfo", 0); + fprintf (stderr, "Error on line %d in %s: %s\n", + obm->tcl->errorLine, cb->userproc, + errstr ? errstr : obm->tcl->result); + done = True; + } else + done = (strcmp (obm->tcl->result, "done") == 0) ? True : False; + + if (done) { + unlink_callback (&obj->server, cb); + XtFree ((char *)cb); + } + + return (done); +} + + +/* serverDeleteWorkProc -- Delete a work callback procedure. + * + * Usage: deleteWorkProc id + * + * The ID string is returned by postWorkProc when a work procedure is + * posted. + */ +static int +serverDeleteWorkProc (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + register ServerObject obj = (ServerObject) object; + ServerCallback cb; + XtIntervalId id; + + if (argc < 2) + return (TCL_ERROR); + + cb = (ServerCallback) strtol (argv[1], (char **)NULL, 16); + XtRemoveWorkProc (cb->id.workProcId); + unlink_callback (&obj->server, cb); + XtFree ((char *)cb); + return (TCL_OK); +} + + +/* link_callback -- Link a callback descriptor into the global server + * callback list. + */ +static void +link_callback (server, cb) +register ServerPrivate server; +register ServerCallback cb; +{ + if (!server->cb_head) { + server->cb_head = cb; + server->cb_tail = cb; + } else { + server->cb_tail->next = cb; + server->cb_tail = cb; + } +} + + +/* unlink_callback -- Unlink a callback descriptor from the global server + * callback list. + */ +static void +unlink_callback (server, cb) +register ServerPrivate server; +register ServerCallback cb; +{ + register ServerCallback cp; + + if (cb == server->cb_head) { + if (!(server->cb_head = cb->next)) + server->cb_tail = NULL; + } else { + for (cp = server->cb_head; cp && cp->next != cb; cp = cp->next) + ; + if (cp) { + cp->next = cb->next; + if (cb == server->cb_tail) + server->cb_tail = cp; + } + } +} + + +/* serverCreateBitmap -- Create a named bitmap. This replaces any old bitmap + * of the same name. The new bitmap is cached in server memory; when a widget + * bitmap resource is set, the bitmap cache will be searched for the named + * bitmap before asking Xlib to find the bitmap. + * + * Usage: createBitmap name width height data + * + * e.g., + * createBitmap foo 16 16 { + * 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x01, + * 0x60,0x03,0x20,0x02,0x60,0x03,0xc0,0x01,0x00,0x00,0x00,0x00, + * 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 } + */ +static int +serverCreateBitmap (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + ServerObject obj = (ServerObject) object; + ObmContext obm = (ObmContext) obj->server.obm; + char *name, *pixels; + int width, height; + int status; + + if (argc < 5) + return (TCL_ERROR); + + name = argv[1]; + width = atoi (argv[2]); + height = atoi (argv[3]); + pixels = argv[4]; + + status = createBitmap (obm, name, width, height, pixels); + return (status == OK ? TCL_OK : TCL_ERROR); +} + + +/* createBitmap -- Create a bitmap of the indicated size and add it to the + * pixmap cache. + */ +createBitmap (obm, name, width, height, pixels) +ObmContext obm; +char *name; +int width, height; +char *pixels; +{ + register char *ip, *op; + register ObjList lp, last_lp; + char numbuf[32], *data, *dp; + Icon *icon; + int nchars; + + if (!obm->specified || !obm->display) + return (TCL_ERROR); + + /* Check if bitmap is already in cache. */ + for (last_lp = lp = obm->pixmap_cache; lp; lp = lp->next) { + if (strcmp (name, lp->name) == 0) + break; + last_lp = lp; + } + + /* Get an empty bitmap descriptor. */ + if (lp) { + if (lp->ptr) + freeIcon (obm, (Icon *) lp->ptr); + } else { + lp = (ObjList) XtMalloc (sizeof (struct objList)); + if (last_lp) + last_lp->next = lp; + else + obm->pixmap_cache = lp; + strcpy (lp->name, name); + lp->next = NULL; + } + + /* Get bitmap data. */ + data = (char *) XtCalloc (nchars = (width * height), 1); + for (dp=data, ip=pixels; *ip; ) { + while (isspace(*ip) || *ip == ',') + ip++; + for (op=numbuf; *ip && !(isspace(*ip) || *ip == ','); ) + *op++ = *ip++; + *op++ = '\0'; + if (--nchars >= 0) + *dp++ = strtol (numbuf, NULL, 0); + } + + /* Create the bitmap. */ + if (!(icon = (Icon *) XtCalloc (1, sizeof (*icon)))) + return (TCL_ERROR); + icon->pixmap = XCreateBitmapFromData (obm->display, + RootWindowOfScreen (obm->screen), data, width, height); + lp->ptr = (caddr_t) icon; + + XtFree ((char *)data); + return (OK); +} + + +/* findBitmap -- Search the bitmap cache for the named bitmap. Note that + * a bitmap is a pixmap of depth one, hence bitmaps are stored in the pixmap + * cache. + */ +Pixmap +findBitmap (obm, name) +ObmContext obm; +char *name; +{ + return (findPixmap (obm, name)); +} + + +/* serverCreatePixmap -- Create a named pixmap. This replaces any old pixmap + * of the same name. The new pixmap is cached in server memory; when a widget + * pixmap resource is set, the pixmap cache will be searched for the named + * pixmap before asking Xlib to find the pixmap. + * + * Usage: createPixmap name width height depth fg_color bg_color data + * + * e.g., + * createPixmap foo 16 16 8 black white { + * 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc0,0x01, + * 0x60,0x03,0x20,0x02,0x60,0x03,0xc0,0x01,0x00,0x00,0x00,0x00, + * 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00 } + */ +static int +serverCreatePixmap (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + ServerObject obj = (ServerObject) object; + ObmContext obm = (ObmContext) obj->server.obm; + int width, height, depth; + char *name, *pixels; + unsigned long fg, bg; + int status; + + if (argc < 8) + return (TCL_ERROR); + + name = argv[1]; + width = atoi (argv[2]); + height = atoi (argv[3]); + depth = atoi (argv[4]); + pixels = argv[7]; + + /* Get fg_color pixel value. */ + if (isdigit (*argv[5])) + fg = strtol (argv[5], NULL, 0); + else { + XrmValue from, to; + from.size = strlen (argv[5]) + 1; + from.addr = argv[5]; + to.addr = (caddr_t) &fg; + to.size = sizeof(fg); + + if (!XtConvertAndStore (obm->toplevel, + XtRString, &from, XtRPixel, &to)) + fg = BlackPixelOfScreen (obm->screen); + } + + /* Get bg_color pixel value. */ + if (isdigit (*argv[6])) + bg = strtol (argv[6], NULL, 0); + else { + XrmValue from, to; + from.size = strlen (argv[6]) + 1; + from.addr = argv[6]; + to.addr = (caddr_t) &bg; + to.size = sizeof(bg); + + if (!XtConvertAndStore (obm->toplevel, + XtRString, &from, XtRPixel, &to)) + bg = WhitePixelOfScreen (obm->screen); + } + + status = createPixmap (obm, name, width,height,8, NULL, pixels, fg,bg); + return (status == OK ? TCL_OK : TCL_ERROR); +} + + +/* createPixmap -- Create a pixmap of the indicated size and add it to the + * pixmap cache. If PIXMAP is non-null the existing pixmap is merely entered + * into the pixmap cache. Otherwise, if PIXELS is NULL an empty pixmap is + * created, otherwise PIXELS points to a character string containing the + * pixmap data in bitmap format, and BG and FG give the background and + * foreground colors. + */ +createPixmap (obm, name, width, height, depth, pixmap, pixels, bg, fg) +ObmContext obm; +char *name; +int width, height, depth; +Pixmap pixmap; +char *pixels; +unsigned long fg, bg; +{ + register char *ip, *op; + register ObjList lp, last_lp; + char numbuf[32], *data, *dp; + Icon *icon; + int nchars; + + if (!obm->specified || !obm->display) + return (TCL_ERROR); + + /* Check if pixmap is already in cache. */ + for (last_lp = lp = obm->pixmap_cache; lp; lp = lp->next) { + if (strcmp (name, lp->name) == 0) + break; + last_lp = lp; + } + + /* Get an empty pixmap descriptor. */ + if (lp) { + if (lp->ptr) + freeIcon (obm, (Icon *) lp->ptr); + } else { + lp = (ObjList) XtMalloc (sizeof (struct objList)); + if (last_lp) + last_lp->next = lp; + else + obm->pixmap_cache = lp; + strcpy (lp->name, name); + lp->next = NULL; + } + + if (!(icon = (Icon *) XtCalloc (1, sizeof (*icon)))) + return (TCL_ERROR); + + /* Get pixmap data. */ + if (pixmap) { + icon->pixmap = pixmap; + } else { + if (pixels) { + data = (char *) XtCalloc (nchars = (width * height), 1); + for (dp=data, ip=pixels; *ip; ) { + while (isspace(*ip) || *ip == ',') + ip++; + for (op=numbuf; *ip && !(isspace(*ip) || *ip == ','); ) + *op++ = *ip++; + *op++ = '\0'; + if (--nchars >= 0) + *dp++ = strtol (numbuf, NULL, 0); + } + + /* Create the pixmap. */ + icon->pixmap = XCreatePixmapFromBitmapData (obm->display, + RootWindowOfScreen(obm->screen), data, width,height, fg,bg, + depth); + + } else { + /* Create the pixmap. */ + icon->pixmap = XCreatePixmap (obm->display, + RootWindowOfScreen(obm->screen), width, height, depth); + } + } + + lp->ptr = (caddr_t) icon; + XtFree ((char *)data); + + return (OK); +} + + +/* serverCreateXPixmap -- Create a pixmap of the given name. The pixmap is + * specified in XPM format which provides much better support for color than + * the simpler format used by createPixmap. + * + * The new pixmap replaces any old pixmap of the same name. The new pixmap + * is cached in server memory; when a widget pixmap resource is set, the + * pixmap cache will be searched for the named pixmap before asking Xlib to + * find the pixmap. + * + * Usage: createXPixmap name widget description + * + * where "name" is the name of the pixmap to be created, "widget" is the + * name of a widget object to be used to search for pixel resources (to color + * the pixmap), and "description" is the XPM format description of the pixmap. + * + * For example: + * + * createXPixmap empty_diamond font1 { + * [* XPM *] + * static char * diamond0c [] = { + * [* width height ncolors cpp [x_hot y_hot] *] + * "17 17 3 1 0 0", + * [* colors *] + * " s none m none c none", + * ". s topShadowColor m white c #c8c8c8c8c8c8", + * "X s bottomShadowColor m black c #646464646464", + * [* pixels *] + * " ", + * " ", + * " ... ", + * " .. .. ", + * " .. .. ", + * " .. .. ", + * " .. .. ", + * " .. .. ", + * " . . ", + * " XX XX ", + * " XX XX ", + * " XX XX ", + * " XX XX ", + * " XX XX ", + * " XXX ", + * " ", + * " "}; + * } + * + * In the above the C style comments have been replaced by [* ... *] to avoid + * prematurely terminating the C comment you are reading. The actual text + * input to createXPixmap should use C style comments, exactly as in the XPM + * file. + * + * The pixmap is specified in XPM format as an array of strings. C style + * coments, commas, and whitespace are ignored (but are permitted, to allow + * XPM files to be directly included). The XPM format is fully defined in + * the XPM documentation, but there is not really that much to it, so we + * summarize it here. The advantage of the XPM format is that it uses a + * visual ascii representation of the pixmap, and it provides good support + * for colored pixmaps, using characters to indicate the color. The fields + * of the color description are as follows: + * + * character character used in "pixels" to signify color (arbitrary) + * s resource name used in application to override color + * m default color on monochrome screens + * g4 for 4-level grayscale screens + * g for grayscale with more than 4 levels + * c for color screens + * + * An important feature of createXPixmap is the reference widget. When the + * pixmap is created the resource list of the named reference widget will be + * searched for any resources that specify colors. If the resource name for + * a color resource matches the "s" name given for a color in the XPM pixmap + * description, then the widget-specific color will be used. This allows + * resources to be used to specify the colors for a pixmap on a per-widget + * basis. If a dummy widget-object name is given (e.g. "none") or no matching + * resources are found, the default colors will be used. Any widget object + * that has color resources may be used for the reference widget (it doesn't + * have to be the widget which will later use the pixmap). + * + * A pixmap created with createXPixmap may be used with the widget-class "set" + * command to set the value of any Pixmap or Icon class widget resource. + */ +static int +serverCreateXPixmap (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + ServerObject obj = (ServerObject) object; + ObmContext obm = (ObmContext) obj->server.obm; + char *name, *widget, *description; + int status; + + if (argc < 4) + return (TCL_ERROR); + + name = argv[1]; + widget = argv[2]; + description = argv[3]; + while (isspace (*description)) + description++; + + status = createXPixmap (obm, name, widget, description); + return (status == OK ? TCL_OK : TCL_ERROR); +} + + +/* createXPixmap -- Create a pixmap defined in an XPM format description and + * add it to the pixmap cache. DESCRIPTION points to a character string + * containing the pixmap description in XPM format. A reference widget object + * may be given to associate color resources with the pixmap. + */ +createXPixmap (obm, name, widget, description) +ObmContext obm; +char *name; +char *widget; +char *description; +{ + register char *ip, *op; + register ObjList lp, last_lp; + XpmImage image; + ObmObject obj; + String *data; + Icon *icon; + int status; + Widget w; + + if (!obm->specified || !obm->display) + return (TCL_ERROR); + + /* Get reference widget if any. */ + w = NULL; + if (obj = obmFindObject (obm, widget, obm->toplevel)) + w = widgetGetPointer (obj); + + /* Create the pixmap (actually icon). + */ + status = XpmCreateXpmImageFromBuffer (description, &image, NULL, NULL); + if (status != XpmSuccess) + return (TCL_ERROR); + XpmCreateDataFromXpmImage (&data, &image, NULL); + + if (data) { + static XpmColorSymbol table[MAXCOLORSYM]; + Cardinal n; + + if (!(icon = (Icon *) XtCalloc (1, sizeof(*icon)))) + return (TCL_ERROR); + + build_colorlist (w, table, XtNumber(table), &n); + icon->attributes.colorsymbols = table; + icon->attributes.numsymbols = n; + icon->attributes.valuemask = XpmColorSymbols; + + XpmCreatePixmapFromData (obm->display, + RootWindowOfScreen(obm->screen), data, + &icon->pixmap, &icon->mask, &icon->attributes); + + XtFree ((String) data); +/* XtFree ((String) table);*/ + XpmFreeXpmImage (&image); + + } else { + XpmFreeXpmImage (&image); + return (TCL_ERROR); + } + + /* Check if pixmap is already in cache. */ + for (last_lp = lp = obm->pixmap_cache; lp; lp = lp->next) { + if (strcmp (name, lp->name) == 0) + break; + last_lp = lp; + } + + /* Get an empty pixmap descriptor. */ + if (lp) { + if (lp->ptr) + freeIcon (obm, (Icon *) lp->ptr); + } else { + lp = (ObjList) XtMalloc (sizeof (struct objList)); + if (last_lp) + last_lp->next = lp; + else + obm->pixmap_cache = lp; + strcpy (lp->name, name); + lp->next = NULL; + } + + lp->ptr = (caddr_t) icon; + return (OK); +} + + +/* build_colorlist -- Get a list of all the color resources defined by a + * widget. This looks through all the resources for resources that specify + * a color (Pixel). All such resources and their values are entered in the + * output table. + * + * To get at the resource value, the resource_offset (an unsigned int) must be + * added to the base address of the widget. The widget pointer is first + * converted to an unsigned long, tehn the offset is added to it and the result + * is converted back to a pointer, in this case a pointer to a Pixel. + * + * This code is based on build_colortable from icon.c in the FWF sources. + */ +static void +build_colorlist (w, table, size, n) +Widget w; +register XpmColorSymbol *table; +Cardinal size; +Cardinal *n; +{ + Cardinal nres, i; + XtResourceList res; + + *n = 0; + XtGetResourceList (XtClass(w), &res, &nres); + for (i=0; i < nres; i++) + if (strcmp(res[i].resource_type, XtRPixel) == 0 && *n < size) { + table[*n].name = res[i].resource_name; + table[*n].value = NULL; + table[*n].pixel = + * (Pixel*) ((unsigned long) w + res[i].resource_offset); + (*n)++; + } + if (res) + XtFree ((char *)res); /* MF037 */ +} + + +/* findPixmap -- Search the pixmap cache for the named pixmap. + */ +Pixmap +findPixmap (obm, name) +ObmContext obm; +char *name; +{ + register ObjList lp; + + for (lp = obm->pixmap_cache; lp; lp = lp->next) + if (lp->ptr && strcmp (name, lp->name) == 0) + return (((Icon *)lp->ptr)->pixmap); + + return ((Pixmap) NULL); +} + + +/* findIcon -- Search the pixmap cache for the named icon. + */ +Icon * +findIcon (obm, name) +ObmContext obm; +char *name; +{ + register ObjList lp; + + for (lp = obm->pixmap_cache; lp; lp = lp->next) + if (lp->ptr && strcmp (name, lp->name) == 0) + return ((Icon *) lp->ptr); + + return ((Icon *) NULL); +} + + +/* freeIcon -- Free an icon descriptor (pixmap list). + */ +void +freeIcon (obm, icon) +register ObmContext obm; +register Icon *icon; +{ + if (icon->pixmap) + XFreePixmap (obm->display, icon->pixmap); + if (icon->mask) + XFreePixmap (obm->display, icon->mask); + XtFree ((char *) icon); +} + + +/* serverCreateCursor -- Create a cursor from bitmap data. The cursor is + * entered into the server's cursor cache and will override any existing + * entry of the same name. + * + * Usage: createCursor name source mask fg_color bg_color x_hot y_hot + * e.g., + * createCursor foo bitmap1 bitmap2 black white 8 8 + * + * The named bitmaps must be created first with createBitmap. + */ +static int +serverCreateCursor (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + ServerObject obj = (ServerObject) object; + ObmContext obm = (ObmContext) obj->server.obm; + register ObjList lp, last_lp; + XColor fg_color, bg_color; + unsigned long fg, bg; + Pixmap source, mask; + Colormap colormap; + int x_hot, y_hot; + char *name; + + if (!obm->specified || !obm->display) + return (TCL_ERROR); + + if (argc < 8) + return (TCL_ERROR); + + name = argv[1]; + source = findPixmap (obm, argv[2]); + mask = findPixmap (obm, argv[3]); + x_hot = atoi (argv[6]); + y_hot = atoi (argv[7]); + + if (!source) + return (TCL_ERROR); + + colormap = XDefaultColormapOfScreen (obm->screen); + + /* Get fg_color pixel value. */ + if (isdigit (*argv[4])) + fg = strtol (argv[4], NULL, 0); + else { + XrmValue from, to; + from.size = strlen (argv[4]) + 1; + from.addr = argv[4]; + to.addr = (caddr_t) &fg; + to.size = sizeof(fg); + + if (!XtConvertAndStore (obm->toplevel, + XtRString, &from, XtRPixel, &to)) + fg = BlackPixelOfScreen (obm->screen); + + fg_color.pixel = fg; + XQueryColor (obm->display, colormap, &fg_color); + } + + /* Get bg_color pixel value. */ + if (isdigit (*argv[5])) + bg = strtol (argv[5], NULL, 0); + else { + XrmValue from, to; + from.size = strlen (argv[5]) + 1; + from.addr = argv[5]; + to.addr = (caddr_t) &bg; + to.size = sizeof(bg); + + if (!XtConvertAndStore (obm->toplevel, + XtRString, &from, XtRPixel, &to)) + bg = WhitePixelOfScreen (obm->screen); + + bg_color.pixel = bg; + XQueryColor (obm->display, colormap, &bg_color); + } + + /* Check if cursor is already in cache. */ + for (last_lp = lp = obm->cursor_cache; lp; lp = lp->next) { + if (strcmp (name, lp->name) == 0) + break; + last_lp = lp; + } + + /* Get an empty cursor descriptor. */ + if (lp) { + if (lp->ptr) + XFreeCursor (obm->display, (Cursor)lp->ptr); + } else { + lp = (ObjList) XtMalloc (sizeof (struct objList)); + if (last_lp) + last_lp->next = lp; + else + obm->cursor_cache = lp; + strcpy (lp->name, name); + lp->next = NULL; + } + + /* Create the cursor. */ + lp->ptr = (caddr_t) XCreatePixmapCursor (obm->display, + source, mask, &fg_color, &bg_color, x_hot, y_hot); + + return (TCL_OK); +} + + +/* findCursor -- Search the cursor cache for the named cursor. + */ +Cursor +findCursor (obm, name) +ObmContext obm; +char *name; +{ + register ObjList lp; + + for (lp = obm->cursor_cache; lp; lp = lp->next) + if (lp->ptr && strcmp (name, lp->name) == 0) + return ((Cursor) lp->ptr); + + return ((Cursor) NULL); +} + + +/* serverCreateMenu, serverEditMenu -- Create or modify a menu. + * The editMenu function is an alias for createMenu. + * + * Usage: createMenu menu-name parent item-list + * + * e.g., createMenu menu-name parent { + * { label function data [options...] } + * { label function data [options...] } + * (etc.) + * } + * where + * + * menu-name is the object name for the menu popup shell + * parent is the parent widget of the menu shell + * + * label is a menu item label + * + * function is the function to be performed when the menu + * item is selected, e.g., f.exec, f.data, f.space, + * or f.line. + * + * data is function dependent data + * + * options are option-name option-value pairs, as specified + * below. + * + * In the item list the fields label and option-value may be any Tcl + * expression. Expressions are evaluated in the server context. The data + * field is a Tcl script to be executed when the menu item is selected. + * + * Options are specified as "option option-value". The menu item options + * are as follows. + * + * foreground Foreground color. + * + * background Background color. + * + * bitmap A bitmap to be displayed left justified in the + * label field (e.g. to indicate a parameter setting). + * + * justify Type of text alignment: left, center, right. + * + * sensitive Specifies whether the menu item is active (sensitive= + * true) or inactive (sensitive=false, item grayed out). + * + * accelerator Specifies an input translation (accelerator, e.g., + * keyboard event) which can be used to execute the + * menu item. + * + * The option-value field may be any Tcl expression. + * + * Example: createMenu fileMenu toplevel { + * { "File Menu" f.title } + * { Open f.exec openFile } + * { Save f.exec saveFile } + * { Load f.menu loadMenu } + * { no-label f.line } + * { Quit f.exec "send client Quit" } + * } + * + * The first createMenu is called for a given menu the menu is created, + * added to the menu list, and all window system widgets are created for + * the menu. Subsequent calls will result in only the changed parts of the + * menu being altered provided the changes are not great. Hence this routine + * can be called to efficiently modify a menu when minor runtime changes + * occur, e.g., an item label or action changes, the item value changes state, + * and so on, without need for the GUI code to know how to make the necessary + * detailed changes to the widgets used to implement the menu. + */ +static int +serverCreateMenu (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + ServerObject obj = (ServerObject) object; + ObmContext obm = (ObmContext) obj->server.obm; + register MenuPtr mp, o_mp; + register MenuItem ip; + register ObjList lp, newobj; + char *menu_name, *menu_label; + char *parent, *item_list; + char **items, **fields; + int nitems, nfields; + int field, item; + ObmObject pobj; + Widget w, pw; + + if (obm->being_destroyed) + return (TCL_OK); + if (!obm->specified || !obm->display) + return (TCL_ERROR); + if (argc < 4) + return (TCL_ERROR); + + menu_name = argv[1]; + parent = argv[2]; + item_list = argv[3]; + + /* Locate the parent widget. */ + if ((pobj = (ObmObject) obmFindObject (obm, parent)) == NULL) { + fprintf (stderr, "obm: cannot find parent widget %s for menu %s\n", + parent, menu_name); + return (TCL_ERROR); + } else + pw = widgetGetPointer (pobj); + + /* Ignore request if parent is being destroyed. */ + if (pobj->core.being_destroyed) + return (TCL_OK); + + /* Get the list of menu item specifier strings. */ + if (Tcl_SplitList (tcl, item_list, &nitems, &items) != TCL_OK) { + fprintf (stderr, "obm: error parsing menu for %s\n", menu_name); + return (TCL_ERROR); + } else if (nitems > MAX_MENUITEMS) + nitems = MAX_MENUITEMS; + + /* Allocate a new, empty menu descriptor. */ + mp = (MenuPtr) XtCalloc (1, sizeof (Menu)); + + /* Process each item and add it to the menu descriptor. */ + for (item=0; item < nitems; item++) { + if (Tcl_SplitList (tcl, items[item], &nfields, &fields) != TCL_OK) { + fprintf (stderr, "obm: error parsing menu item %d of %s\n", + item + 1, menu_name); + continue; + } + + ip = &mp->items[mp->nitems++]; + + /* The first three fields label,type,data have a fairly strict + * syntax and must be in order. Try to interpret the label field + * as a string expression; if this fails, assume it is a literal + * label string. + */ + field = 0; + if (strncmp (fields[field], "f.", 2) == 0) + ip->label = NULL; + else { + char *cp = fields[field++]; + + if (Tcl_ExprString (tcl, cp) != TCL_OK) + ip->label = cp; + else { + ip->label = XtMalloc (strlen(tcl->result) + 1); + strcpy (ip->label, tcl->result); + ip->flags |= M_FreeLabel; + } + } + + /* Determine menu item type. */ + if (strcmp (fields[field], "f.exec") == 0) { + ip->type = MI_EXEC; + ip->data = fields[++field]; + } else if (strcmp (fields[field], "f.line") == 0) { + ip->type = MI_LINE; + ip->data = NULL; + } else if (strcmp (fields[field], "f.dblline") == 0) { + ip->type = MI_DBLLINE; + ip->data = NULL; + } else if (strcmp (fields[field], "f.menu") == 0) { + ip->type = MI_MENU; + ip->data = fields[++field]; + } else if (strcmp (fields[field], "f.space") == 0) { + ip->type = MI_SPACE; + ip->data = fields[++field]; + } else if (strcmp (fields[field], "f.title") == 0) { + ip->type = MI_TITLE; + ip->data = NULL; + } else { + fprintf (stderr, "obm: bad menu item type `%s'\n", + fields[field]); + ip->type = MI_IGNORE; + ip->data = NULL; + } + field++; + + /* Process any optional menu item attributes. */ + for ( ; field < nfields; field++) { + if (strcmp (fields[field], "background") == 0) { + ip->background = fields[++field]; + + } else if (strcmp (fields[field], "foreground") == 0) { + ip->foreground = fields[++field]; + + } else if (strcmp (fields[field], "bitmap") == 0) { + char *cp = fields[++field]; + + if (Tcl_ExprString (tcl, cp) != TCL_OK) + ip->pixmap = findBitmap (obm, cp); + else + ip->pixmap = findBitmap (obm, tcl->result); + + } else if (strcmp (fields[field], "justify") == 0) { + char *justify = fields[++field]; + if (strcmp (justify, "left") == 0) + ip->justify = XtJustifyLeft; + else if (strcmp (justify, "center") == 0) + ip->justify = XtJustifyCenter; + else if (strcmp (justify, "right") == 0) + ip->justify = XtJustifyRight; + + } else if (strcmp (fields[field], "sensitive") == 0) { + int ch = fields[++field][0]; + int bval; + + if (ch == 'f' || ch == 'F') + ip->flags |= M_Insensitive; + else if (ch == 't' || ch == 'T') + ip->flags &= ~M_Insensitive; + else { + if (Tcl_ExprBoolean (tcl, + fields[field], &bval) != TCL_OK) { + fprintf (stderr, + "menu %s.%d sensitive option: %s\n", + menu_name, item, tcl->result); + } else if (!bval) + ip->flags |= M_Insensitive; + } + + } else if (strncmp (fields[field], "accelerator", 5) == 0) { + ip->accelerator = fields[++field]; + + } else { + fprintf (stderr, "obm: bad menu item parameter `%s'\n", + fields[field]); + } + } + + /* Save the string buffer pointer to be freed by menuFree. */ + ip->sbuf = (char *) fields; + } + + /* Free list of menu item specification strings. */ + free ((char *) items); + + /* Search the menu list and see if there is already a menu with + * the given menu name. + */ + for (lp = obm->menu_list, o_mp=NULL; lp; lp = lp->next) + if (strcmp (lp->name, menu_name) == 0) { + o_mp = (MenuPtr) lp->ptr; + break; + } + + /* If the menu already exists try to edit it, otherwise delete any + * existing menu and create a new one from scratch. + */ + if (o_mp && editMenu (o_mp, mp) == 0) { + /* The edit succeeded. Discard the request descriptor. */ + freeMenu (mp); + + } else if (o_mp) { + /* Replace an existing menu. */ + obmDestroyObject (obm, o_mp->obj); + freeMenu (o_mp); + createMenu (obm, mp, menu_name, parent, pw); + lp->ptr = (caddr_t) mp; + + } else { + /* Create a new menu. */ + createMenu (obm, mp, menu_name, parent, pw); + + newobj = (ObjList) XtMalloc (sizeof (struct objList)); + strcpy (newobj->name, menu_name); + newobj->ptr = (caddr_t) mp; + newobj->next = NULL; + + if (obm->menu_list == NULL) + obm->menu_list = newobj; + else { + for (lp = obm->menu_list; lp->next; lp = lp->next) + ; + lp->next = newobj; + } + } + + return (TCL_OK); +} + + +/* serverDestroyMenu -- Destroy a menu. This can be used to free up the + * resources used by a menu, e.g., if the menu is not expected to be needed + * again for a while. + * + * Usage: destroyMenu menu-name + */ +static int +serverDestroyMenu (object, tcl, argc, argv) +ObmObject object; +Tcl_Interp *tcl; +int argc; +char **argv; +{ + ServerObject obj = (ServerObject) object; + ObmContext obm = (ObmContext) obj->server.obm; + register ObjList lp, lpp; + register MenuPtr mp; + char *menu_name; + + if (argc < 2) + return (TCL_ERROR); + else + menu_name = argv[1]; + + /* Locate the menu descriptor. */ + for (lp = obm->menu_list, lpp=NULL, mp=NULL; lp; lpp=lp, lp=lp->next) + if (strcmp (lp->name, menu_name) == 0) { + mp = (MenuPtr) lp->ptr; + break; + } + if (mp == NULL) + return (TCL_OK); + + /* Unlink the menu from the menu list. */ + if (lpp == NULL) + obm->menu_list = lp->next; + else + lpp->next = lp->next; + + /* Destroy the menu object and any descendents. */ + obmDestroyObject (obm, mp->obj); + freeMenu (mp); + + return (TCL_OK); +} + + +/* createMenu -- Create a new menu from a menu descriptor. + */ +static void +createMenu (obm, mp, menu_name, parent, pw) +ObmContext obm; +register MenuPtr mp; +char *menu_name; +char *parent; +Widget pw; +{ + register MenuItem ip; + int itemno, menuno, lineno, spaceno; + Widget menu, entry; + char name[SZ_NAME]; + XrmValue from, to[2]; + Pixel value[2]; + Arg args[10]; + int nargs, i; + + menu_classInit(); + + /* The following resources are statically defined for all menus. */ + nargs = 0; + if (mp->items[0].type == MI_TITLE) { + XtSetArg (args[nargs], XtNlabel, mp->items[0].label); + nargs++; + } + + /* Create the menu shell. */ + obmNewObject (obm, menu_name, "SimpleMenu", parent, args, nargs); + mp->obj = obmFindObject (obm, menu_name); + mp->menuShell = menu = widgetGetPointer (mp->obj); + mp->obm = (XtPointer) obm; + + XtAddCallback (menu, XtNpopupCallback, menu_popup, (XtPointer)mp); + XtAddCallback (menu, XtNpopdownCallback, menu_popdown, (XtPointer)mp); + + ip = &mp->items[0]; + itemno = menuno = lineno = spaceno = 1; + + /* Create each menu item. */ + for (i=0; i < mp->nitems; i++) { + ip->menu = (XtPointer)mp; + + /* Create the menu item widget. */ + switch (ip->type) { + case MI_EXEC: + sprintf (name, "item%d", itemno++); + obmNewObject (obm, name, "SmeBSB", menu_name, NULL, 0); + entry = XtNameToWidget (menu, name); + XtAddCallback (entry, XtNcallback, menuSelect, (XtPointer)mp); + break; + + case MI_LINE: + sprintf (name, "line%d", lineno++); + obmNewObject (obm, name, "SmeLine", menu_name, NULL, 0); + entry = XtNameToWidget (menu, name); + break; + + case MI_DBLLINE: + nargs = 0; + XtSetArg (args[nargs], XtNheight, 2); + nargs++; + sprintf (name, "line%d", lineno++); + obmNewObject (obm, name, "SmeLine", menu_name, args, nargs); + sprintf (name, "line%d", lineno++); + obmNewObject (obm, name, "SmeLine", menu_name, args, nargs); + entry = XtNameToWidget (menu, name); + break; + + case MI_MENU: + sprintf (name, "menu%d", menuno++); + obmNewObject (obm, name, "SmeBSB", menu_name, NULL, 0); + entry = XtNameToWidget (menu, name); + XtAddCallback (entry, XtNcallback, menuSelect, (XtPointer)mp); + + menu_addEntry (entry, menu_name, ip->data, obm); + XtAddCallback (entry, XtNdestroyCallback, menu_delEntry, + (XtPointer)NULL); + break; + + case MI_SPACE: + nargs = 0; + XtSetArg (args[nargs], XtNheight, atoi(ip->data)); + nargs++; + sprintf (name, "line%d", lineno++); + obmNewObject (obm, name, "Sme", menu_name, args, nargs); + entry = XtNameToWidget (menu, name); + break; + + case MI_TITLE: + if (i > 0) + fprintf (stderr, + "obm: menu title must be first item in menu\n"); + ip++; + continue; + + default: + /* ignore */ + fprintf (stderr, "obm: unknown menu item type %s[%d]\n", + menu_name, i + 1); + ip++; + continue; + } + + /* Set the item specific resources. */ + nargs = 0; + if (ip->label) { + XtSetArg (args[nargs], XtNlabel, ip->label); + nargs++; + } + if (ip->background || ip->foreground) { + char *s[3]; + int i=0; + + if (ip->background) + s[i++] = ip->background; + if (ip->foreground) + s[i++] = ip->foreground; + s[i++] = NULL; + + for (i=0; s[i]; i++) { + from.size = strlen(s[i]) + 1; + from.addr = s[i]; + to[i].addr = (caddr_t) &value[i]; + to[i].size = sizeof(value[i]); + + if (XtConvertAndStore (entry, + XtRString, &from, XtRPixel, &to[i])) { + XtSetArg (args[nargs], s[i] == ip->background ? + XtNbackground : XtNforeground, value[i]); + nargs++; + } + } + } + if (ip->justify) { + XtSetArg (args[nargs], XtNjustify, ip->justify); + nargs++; + } + if (ip->pixmap) { + XtSetArg (args[nargs], XtNleftBitmap, ip->pixmap); + nargs++; + } + if (ip->type == MI_MENU) { + XtSetArg (args[nargs], XtNrightBitmap, + menu_pullrightBitmap (obm, 0)); + nargs++; + XtSetArg (args[nargs], XtNrightMargin, MB_WIDTH); + nargs++; + } + if (ip->flags & M_Insensitive) { + XtSetArg (args[nargs], XtNsensitive, False); + nargs++; + } + if (ip->accelerator) { + char buf[SZ_MESSAGE]; + sprintf (buf, "%s: notify()", ip->accelerator); + XtSetArg (args[nargs], XtNaccelerators, buf); + nargs++; + } + + if (nargs) + XtSetValues (entry, args, nargs); + ip->entry = entry; + ip++; + } +} + + +/* editMenu -- Edit a menu given descriptors for the current menu and the + * new version. Zero is returned if the edit succeeds. If the menus are + * too different editMenu will play it safe and return nonzero, and the + * caller should delete the old one and create a new menu from scratch. + */ +static int +editMenu (mp, request) +register MenuPtr mp; /* existing menu */ +MenuPtr request; /* requested values */ +{ + register MenuItem old, new; + register int i; + int ncolors=0, nargs=0; + XrmValue from, to[2]; + Pixel value[2]; + Arg args[10]; + + /* Make a quick comparision of the old and new menu descriptors to + * see if they are similar enough for the edit to make sense. + */ + if (mp->nitems != request->nitems) + return (-1); + for (i=0; i < mp->nitems; i++) { + if (mp->items[i].type != request->items[i].type) + return (-1); + } + + /* Edit each menu item. */ + for (i=0; i < mp->nitems; i++) { + old = &mp->items[i]; + new = &request->items[i]; + + nargs = 0; + if (new->label && + (!old->label || strcmp (old->label, new->label))) { + if (old->flags & M_FreeLabel) + old->label = XtRealloc (old->label, strlen(new->label)+1); + else { + old->label = XtMalloc (strlen(new->label) + 1); + old->flags |= M_FreeLabel; + } + strcpy (old->label, new->label); + XtSetArg (args[nargs], XtNlabel, old->label); + nargs++; + } + + if (new->data && (!old->data || strcmp (old->data, new->data))) { + if (old->flags & M_FreeData) + old->data = XtRealloc (old->data, strlen(new->data)+1); + else { + old->data = XtMalloc (strlen(new->data) + 1); + old->flags |= M_FreeData; + } + strcpy (old->data, new->data); + } + + if (new->background && (!old->background || + strcmp (old->background, new->background))) { + + int nchars = strlen (new->background) + 1; + char *s; + + if (old->flags & M_FreeBackground) + old->background = XtRealloc (old->background, nchars); + else { + old->background = XtMalloc (nchars); + old->flags |= M_FreeBackground; + } + strcpy (s = old->background, new->background); + + from.size = strlen(s) + 1; + from.addr = s; + to[ncolors].addr = (caddr_t) &value[ncolors]; + to[ncolors].size = sizeof(value[ncolors]); + + if (XtConvertAndStore (old->entry, + XtRString, &from, XtRPixel, &to[ncolors])) { + XtSetArg (args[nargs], XtNbackground, value[ncolors]); + nargs++; + ncolors++; + } + } + + if (new->foreground && (!old->foreground || + strcmp (old->foreground, new->foreground))) { + + int nchars = strlen (new->foreground) + 1; + char *s; + + if (old->flags & M_FreeForeground) + old->foreground = XtRealloc (old->foreground, nchars); + else { + old->foreground = XtMalloc (nchars); + old->flags |= M_FreeForeground; + } + strcpy (s = old->foreground, new->foreground); + + from.size = strlen(s) + 1; + from.addr = s; + to[ncolors].addr = (caddr_t) &value[ncolors]; + to[ncolors].size = sizeof(value[ncolors]); + + if (XtConvertAndStore (old->entry, + XtRString, &from, XtRPixel, &to[ncolors])) { + XtSetArg (args[nargs], XtNforeground, value[ncolors]); + nargs++; + ncolors++; + } + } + + if (old->justify != new->justify) { + old->justify = new->justify; + XtSetArg (args[nargs], XtNjustify, old->justify); + nargs++; + } + + if (new->accelerator && (!old->accelerator || + strcmp (old->accelerator, new->accelerator))) { + char buf[SZ_MESSAGE]; + int nchars = strlen (new->accelerator) + 1; + sprintf (buf, "%s: notify()", new->accelerator); + + if (old->flags & M_FreeAccel) + old->accelerator = XtRealloc (old->accelerator, nchars); + else { + old->accelerator = XtMalloc (nchars); + old->flags |= M_FreeAccel; + } + strcpy (old->accelerator, new->accelerator); + XtSetArg (args[nargs], XtNaccelerators, buf); + nargs++; + } + + if (old->pixmap != new->pixmap) { + old->pixmap = new->pixmap; + XtSetArg (args[nargs], XtNleftBitmap, new->pixmap); + nargs++; + } + + if ((old->flags & M_Insensitive) != (new->flags & M_Insensitive)) { + if (new->flags & M_Insensitive) { + old->flags |= M_Insensitive; + XtSetArg (args[nargs], XtNsensitive, False); + } else { + old->flags &= ~M_Insensitive; + XtSetArg (args[nargs], XtNsensitive, True); + } + nargs++; + } + + if (old->entry && nargs > 0) + XtSetValues (old->entry, args, nargs); + } + + return (0); +} + + +/* freeMenu -- Free a menu descriptor. + */ +void +freeMenu (mp) +register MenuPtr mp; +{ + register MenuItem ip; + register int i; + + for (i=0; i < mp->nitems; i++) { + ip = &mp->items[i]; + if (ip->type == MI_MENU && ip->entry) + menu_delEntry (ip->entry); + + if ((ip->flags & M_FreeBackground) && ip->background) + XtFree (ip->background); + if ((ip->flags & M_FreeForeground) && ip->foreground) + XtFree (ip->foreground); + if ((ip->flags & M_FreeAccel) && ip->accelerator) + XtFree (ip->accelerator); + if ((ip->flags & M_FreeLabel) && ip->label) + XtFree (ip->label); + if ((ip->flags & M_FreeData) && ip->data) + XtFree (ip->data); + + XtFree (ip->sbuf); + } + + XtFree ((char *)mp); +} + + +/* menuSelect -- Callback routine, called when a menu item is selected. + */ +static void +menuSelect (w, client_data, call_data) +Widget w; +XtPointer client_data; +XtPointer call_data; +{ + register MenuPtr mp = (MenuPtr) client_data; + register MenuItem ip; + register int i; + ObmContext obm = (ObmContext) mp->obm; + + /* Locate the menu item to which the callback refers. */ + for (i=0, ip=NULL; i < mp->nitems; i++) { + ip = &mp->items[i]; + if (ip->entry == w) + break; + } + + /* Ignore callbacks other than for command type menu entries (MI_EXEC). + * In the case of a command entry the data field of the menu item + * descriptor contains the server command to be executed. + */ + + if (ip && ip->type == MI_EXEC) + if (Tcl_Eval (obm->tcl, ip->data) != TCL_OK) { + char *errstr = Tcl_GetVar (obm->tcl, "errorInfo", 0); + fprintf (stderr, "Error %s.%s line %d: %s\n", + mp->obj->core.name, XtName(ip->entry), obm->tcl->errorLine, + errstr ? errstr : obm->tcl->result); + } +} + + +/* + * The following code is used to interpose special highlight() and + * unhighlight() SmeBSB class procedures, to allow menu entries which point to + * submenus to automatically popup and popdown the submenu when the menu entry + * which points to it is highlighted or unhighlighted. It is a bit of a trick + * to replace the standard class procedure as we do here, but this is a lot + * simpler than subclassing the entire SmeBSB widget, and works for both the + * standard Athena and Xaw3D versions of the widget. Tying the submenu + * popup/popdown to the simpleMenu highlight/unhighlight actions allows us + * to let the simpleMenu widget track the pointer and determine when the + * submenu should be displayed. + * + * [Note added later]. Having now implemented this technique for cascaded + * menus I am not sure it was the best way to do this - it might have been + * better to just use motion events. There were a number of subtle problems + * to be solved to get this to work. It is true though, that most of these + * don't have much to do with the interpose-highlight technique, so maybe + * I would have run into the problems anyway. The problems were things like + * state changes when the pointer crosses from a menu pane into a submenu, + * the need to explicitly popdown submenus when the main window is popped + * down or when a nonmenu item in the main menu is entered, getting the + * grabs right, an annoying warning message about trying to remove a grab + * which no longer existed, and so on. Getting the pull-right bitmap to + * look right took a lot of fiddling and it appeared that there might be a + * positioning bug in the Xaw3d code related to this. The one problem that + * was clearly specific to the highlight/unhighlight technique was that + * SmeBSB uses a toggle type function for highlight/unhighlight. This + * assumes that the toggle is always in a known state. This works for a + * single menu, but it appears that there is a bug in the SmeBSB code when + * a pull-right menu obscures the parent menu, causing the toggle to get + * out of phase when moving into the submenu band back out (out of phase + * means that when one calls the unhighlight class procedure, the toggle + * actually highlights, and vice versa). I had to disable highlighting of + * submenu items in a menu to avoid this problem. + */ + +/* The following describes a menu entry widget which calls a submenu. */ +struct _menuEntry { + Widget w; /* this widget */ + char name[SZ_NAME]; /* name of menu containing widget */ + char child[SZ_NAME]; /* submenu name */ + Widget menu; /* shell widget of submenu */ + ObmContext obm; /* obm context */ + struct _menuEntry *next; /* next menuEntry on list */ +}; +typedef struct _menuEntry menuEntry, *MenuEntry; + +MenuEntry menuWidgetList; +static char menu_bitmap1[] = "BSB_pullright1"; +static char menu_bitmap2[] = "BSB_pullright2"; +static void (*BSB_highlight)(); +static void (*BSB_unhighlight)(); + + +/* menu_classInit -- Edit the SME class record to interpose our custom + * highlight/unhighlight class procedures. + */ +static void +menu_classInit() +{ + register SmeClassPart *sme = &smeBSBClassRec.sme_class; + + if (sme->highlight != menu_highlight) { + BSB_highlight = sme->highlight; + sme->highlight = menu_highlight; + } + if (sme->unhighlight != menu_unhighlight) { + BSB_unhighlight = sme->unhighlight; + sme->unhighlight = menu_unhighlight; + } +} + + +/* menu_pullrightBitmap -- Return the bitmap id of the pullright bitmap + * displayed on the right side of a menu entry that brings up a submenu. + */ +static Pixmap +menu_pullrightBitmap (obm, state) +ObmContext obm; +int state; +{ + Pixmap bitmap; + + if (bitmap = findBitmap (obm, state ? menu_bitmap2 : menu_bitmap1)) + return (bitmap); + + createBitmap (obm, menu_bitmap1, MB_WIDTH, MB_HEIGHT, MB1_PIXELS); + createBitmap (obm, menu_bitmap2, MB_WIDTH, MB_HEIGHT, MB2_PIXELS); + + if (bitmap = findBitmap (obm, state ? menu_bitmap2 : menu_bitmap1)) + return (bitmap); + else + return ((Pixmap)NULL); +} + + +/* menu_addEntry -- Add a widget to the menuWidgetList list. + */ +static void +menu_addEntry (w, name, child, obm) +Widget w; /* menu entry which calls submenu */ +char *name; /* name of menu containing this widget */ +char *child; /* name of submenu shell widget */ +ObmContext obm; +{ + register MenuEntry mw, new; + + for (mw=menuWidgetList; mw && mw->next; mw = mw->next) + if (mw->w == w) + return; + + if ((new = (MenuEntry) XtCalloc (1, sizeof (menuEntry))) == NULL) + return; + + new->w = w; + strcpy (new->name, name); + strcpy (new->child, child); + new->obm = obm; + + if (mw) + mw->next = new; + else + menuWidgetList = new; +} + + +/* menu_delEntry -- Delete a widget from the menuWidgetList list. + */ +static void +menu_delEntry (w, client_data, call_data) +register Widget w; +XtPointer client_data; /* not used */ +XtPointer call_data; /* not used */ +{ + register MenuEntry mw, prev_mw; + + for (mw=menuWidgetList, prev_mw=NULL; mw; prev_mw=mw, mw=mw->next) + if (mw->w == w) + break; + + if (mw) { + if (prev_mw) + prev_mw->next = mw->next; + else + menuWidgetList = NULL; + XtFree ((char *)mw); + } +} + + +/* menu_popup -- Called when a menu is popped up. + */ +static void +menu_popup (w, client_data, call_data) +Widget w; +XtPointer client_data; +XtPointer call_data; /* not used */ +{ + register MenuPtr mp = (MenuPtr) client_data; + mp->popped_up = True; +} + + +/* menu_popdown -- Called when a menu is popped down. Make sure any + * child menus are popped down before popping down the parent. + */ +static void +menu_popdown (w, client_data, call_data) +Widget w; +XtPointer client_data; +XtPointer call_data; /* not used */ +{ + register MenuPtr mp = (MenuPtr) client_data; + ObmContext obm = (ObmContext) mp->obm; + register MenuEntry mw; + register MenuPtr mm; + MenuItem mi; + int i; + + /* This routine is called with w=NULL to popdown any child menus. + * If w is not NULL that means we are being called as a + * popdownCallback for the menu shell. + */ + if (w) + mp->popped_up = False; + + for (i=0; i < mp->nitems; i++) { + mi = &mp->items[i]; + if (mi->type == MI_MENU) { + /* Locate menu descriptor for named menu. */ + mm = findMenu (obm, mi->data); + + /* Popdown the child menu (if necessary). The temporary dummy + * warning message handler appears to be the only way to avoid + * a warning messages about an attempt to remove a grab for a + * widget on the grab list. What happens is that when + * XtPopdown is called on the main menu this calls + * XtRemoveGrab on the window, which removes any grabs for the + * main window _and any later grabs_, i.e., for the submenus. + * XtPopdown then calls the menu_popdown popdown callback, + * which is necessary to popdown any child menus as XtPopdown + * does not do this. The XtPopdown called in this routine + * tries to remove a grab which has already been removed, + * causing the warning message. The situation itself appears + * to be harmless, so the best thing to do is just disable the + * warning message. + */ + if (mm && mm->menuShell) { + XtErrorMsgHandler old_handler; + + old_handler = XtAppSetWarningMsgHandler (obm->app_context, + (XtErrorMsgHandler) menu_popdown_msgHandler); + XtPopdown (mm->menuShell); + XtAppSetWarningMsgHandler (obm->app_context, old_handler); + } + } + } +} + + +/* menu_popdown_msgHandler -- Dummy warning message handler used in menu + * popdown above. + */ +static void +menu_popdown_msgHandler (name,type,class,defaultp,params,num_params) +String name,type,class,defaultp; +String* params; +Cardinal* num_params; +{ +} + + +/* menu_highlight -- Custom version of the simpleMenu class action highlight + * procedure, called when a menu entry is highlighted. This is identical to + * the standard class procedure (in fact we call the standard class highlight + * procedure) except that we check to see if the widget being highlighted + * is a submenu, and if so, popup the submenu. + */ +static void +menu_highlight (w) +register Widget w; +{ + register MenuEntry mw, sm; + ObmContext obm = global_obm_handle; + MenuPtr mp; + + /* If we are highlighting an entry in a menu then any pull-right + * submenus which are still up should not be, so get rid of them. + */ + if (mp = findMenu (obm, XtName(w->core.parent))) + menu_popdown ((Widget)NULL, (XtPointer)mp, (XtPointer)NULL); + + /* Is the menu entry being highlighted on our list of call-submenu + * widgets? + */ + for (mw=menuWidgetList; mw; mw = mw->next) + if (mw->w == w) + break; + + /* If the menu item is for a submenu, popup the submenu. */ + if (mw) { + Position x, y; + Position menu_x, menu_y; + Dimension parent_width; + Dimension menu_width, menu_height; + char target[SZ_NAME]; + ObmContext obm = mw->obm; + Widget menu; + + /* If the parent menu is not popped up, do not pop up the + * child. This doesn't sound likely but it can happen when + * menu_highlight is called after a button-up event which + * pops down the main menu. + */ + if (mp && mp->popped_up == False) + return; + + /* Get shell widget of submenu. */ + if (!(mp && (mw->menu = XtNameToWidget (mp->menuShell, target)))) { + sprintf (target, "*%s", mw->child); + if (!(mw->menu = XtNameToWidget (obm->toplevel, target))) + return; + } + + menu = mw->menu; + XtTranslateCoords (w, 0, 0, &x, &y); + XtVaGetValues (w, XtNwidth, &parent_width, NULL); + + menu_width = menu->core.width + 2 * menu->core.border_width; + menu_height = menu->core.height + 2 * menu->core.border_width; + menu_x = x + parent_width - 5; + menu_y = y - 5; + + if (menu_x >= 0) { + int scr_width = WidthOfScreen(XtScreen(menu)); + if ((int)(menu_x + menu_width) > (int)scr_width) + menu_x = scr_width - menu_width; + } + if (menu_x < 0) + menu_x = 0; + + if (menu_y >= 0) { + int scr_height = HeightOfScreen(XtScreen(menu)); + if ((int)(menu_y + menu_height) > (int)scr_height) + menu_y = scr_height - menu_height; + } + if (menu_y < 0) + menu_y = 0; + + XtVaSetValues (menu, + XtNx, menu_x, + XtNy, menu_y, + NULL); + /* + * This appears to bring out a bug in the Xaw|Xaw3d SmeBSB. + * + XtVaSetValues (w, + XtNrightBitmap, menu_pullrightBitmap (obm, 1), + NULL); + */ + + /* Popup the pull-right menu. */ + XtPopup (menu, XtGrabNonexclusive); + + } else { + /* Call the standard simplemenu highlight method. */ + BSB_highlight (w); + } +} + + +/* menu_unhighlight -- Custom unhighlight class procedure, interposed in + * front of the standard class procedure. + */ +static void +menu_unhighlight (w) +register Widget w; +{ + register MenuEntry mw; + + /* Is the menu entry being unhighlighted on our list of call-submenu + * widgets? + */ + for (mw=menuWidgetList; mw; mw = mw->next) + if (mw->w == w) + break; + + if (mw == NULL) { + /* Now call the standard class unhighlight procedure. */ + BSB_unhighlight (w); + + } else if (mw->menu) { + /* Popdown the submenu. + */ + ObmContext obm = mw->obm; + Dimension width, height; + int in_window, i; + XMotionEvent *ev; + XEvent event; + Position x, y; + Widget wl[2]; + + /* Get the next window event. All we are looking for here is + * the pointer coordinates. + */ + ev = (XMotionEvent *) &event; + while (!XtAppPeekEvent (obm->app_context, &event)) + ; + + wl[0] = w; + wl[1] = mw->menu; + in_window = 0; + + /* Check if the pointer is in either the pull-right pane of + * the parent menu, or the pull-right menu itself. + */ + for (i=0; i < 2; i++) { + XtTranslateCoords (wl[i], 0, 0, &x, &y); + XtVaGetValues (wl[i], + XtNwidth, &width, + XtNheight, &height, + NULL); + + if (ev->x_root >= x && ev->x_root < x + (Position)width && + ev->y_root >= y && ev->y_root < y + (Position)height) { + in_window++; + break; + } + } + + /* If it is not in either window then go ahead and popdown the + * child menu, otherwise ignore the request. Erroneous requests + * can occur when the pointer is in crossing from one window + * to the other. + */ + if (!in_window) { + /* + * This appears to bring out a bug in the Xaw3d SmeBSB. + XtVaSetValues (w, + XtNrightBitmap, menu_pullrightBitmap (obm, 0), + NULL); + */ + + XtPopdown (mw->menu); + } + } +} + + +/* findMenu -- Return the menu descriptor of a menu given its name. + */ +static MenuPtr +findMenu (obm, name) +register ObmContext obm; +char *name; +{ + register ObjList lp; + + for (lp = obm->menu_list; lp; lp = lp->next) + if (strcmp (lp->name, name) == 0) + return ((MenuPtr) lp->ptr); + + return (NULL); +} |