(* Copyright (C) 1989, 1990 Digital Equipment Corporation *) (* All rights reserved. *) (* See the file COPYRIGHT for a full description. *) (* File: popup.m3 *) (* Last modified on Thu Apr 12 00:43:08 1990 by muller *) (* modified on Thu Feb 15 14:43:21 1990 by jerome *) (*==============================================================*) (* The X11 R4 Interface for Modula 3 *) (* *) (* The Athena Widgets Set Example (re)coded in Modula3 *) (*==============================================================*) (* * An example of how to create a popup dialog box. * * August 17, 1989 - Donna Converse * November 30, 1989 - Chris D. Peterson *) (* * $XConsortium: popup.c,v 1.6 89/12/15 19:33:13 kit Exp $ * * Copyright 1989 Massachusetts Institute of Technology * * Permission to use, copy, modify, distribute, and sell this software and its * documentation for any purpose is hereby granted without fee, provided that * the above copyright notice appear in all copies and that both that * copyright notice and this permission notice appear in supporting * documentation, and that the name of M.I.T. not be used in advertising or * publicity pertaining to distribution of the software without specific, * written prior permission. M.I.T. makes no representations about the * suitability of this software for any purpose. It is provided "as is" * without express or implied warranty. * * M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL M.I.T. * BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION * OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) UNSAFE MODULE popup EXPORTS Main; FROM M3toC IMPORT TtoS, StoT, PtoI, ItoP, nullString, argc, argv; IMPORT Wr, Stdio, Ctypes, Cstring, Cstdlib, X, Xrm, Xt, XtN, XtR, Xaw; (* Function Name: Syntax * Description: Prints the calling syntax for this program to stdout. * Arguments: app_con - the application context. * call - the name of the application. * Returns: none - exits tho. *) PROCEDURE Syntax (app_con: Xt.AppContext; call: Xt.String) = BEGIN Xt.DestroyApplicationContext (app_con); Wr.PutText (Stdio.stdout, "Usage: " & StoT (call) & "\n"); Cstdlib.exit (1); END Syntax; (* Function Name: PopupPrompt * Description: Creates and pops up the Dialog widget to ask for a new * button color. * Arguments: button - the command button that activated this function. * client_data, call_data - *** UNUSED *** * Returns: none. *) PROCEDURE PopupPrompt (button: Xt.Widget; <*UNUSED*> client_data, call_data: ADDRESS) = VAR args := NEW (Xt.ArgList); popup: Xt.Widget; dialog: Xt.Widget; x, y: Xt.Position; width, height: Xt.Dimension; n: Xt.Cardinal; BEGIN (* * This will position the upper left hand corner of the popup at the * center of the widget which invoked this callback, which will also * become the parent of the popup. I don't deal with the possibility * that the popup will be all or partially off the edge of the screen. *) n := 0; args[n] := Xt.Arg {XtN.width, ADR (width)}; INC (n); args[n] := Xt.Arg {XtN.height, ADR (height)}; INC (n); Xt.GetValues (button, args, n); Xt.TranslateCoords (button, width DIV 2, height DIV 2, ADR (x), ADR (y)); n := 0; args[n] := Xt.Arg {XtN.x, ItoP (x)}; INC (n); args[n] := Xt.Arg {XtN.y, ItoP (y)}; INC (n); popup := Xt.CreatePopupShell (TtoS ("prompt"), Xaw.transientShellWidgetClass, button, args, n); (* * The popup will contain a dialog box, prompting the user for input. *) dialog := Xt.CreateManagedWidget (TtoS ("dialog"), Xaw.dialogWidgetClass, popup); (* * The prompting message's size is dynamic; allow it to request resize. *) Xaw.DialogAddButton (dialog, TtoS ("ok"), ColorTheButton, dialog); Xaw.DialogAddButton (dialog, TtoS ("cancel"), DestroyPopupPrompt, dialog); (* * In this example, it is not necessary to call Xt.RealizeWidget. * There are two situations where you may want to realize the * popup before calling Xt.Popup: * * If you build your popups upon application startup, the time required * to execute Xt.Popup is reduced if you realize your popups first. * * If you want to insure that the popup is not clipped by screen * boundaries, realize the popup before calling Xt.GetValues on it. * * The dialog popup will allow user input to the rest of the application * when the grab kind is GrabNone. Since I allow input to the rest of * the application and since I don't destroy the popup before creating a * new one, I am allowing multiple identical popups, one for each time * the user clicks on the main application button. * * Try it with Xt.GrabExclusive instead of Xt.GrabNone. Will the user * be able to quit the application while the popup is up? Does the * command button which causes the popup to happen remain highlighted? *) Xt.Popup (popup, Xt.GrabNone); END PopupPrompt; (* Function Name: Quit * Description: exits the application. * Arguments: widget, client_data, call_data - *** UNUSED ***. * Returns: none *) PROCEDURE Quit (w: Xt.Widget; <*UNUSED*> client_data, call_data: ADDRESS) = BEGIN Xt.DestroyApplicationContext (Xt.WidgetToApplicationContext (w)); Cstdlib.exit (0); END Quit; (* Function Name: ColorTheButton * Description: This is a callback function that performs the * actual task of coloring in the command button. * Arguments: w - *** UNUSED ***. * client_data - a pointer to the dialog widget. * call_data - *** UNUSED ***. * Returns: none *) PROCEDURE ColorTheButton (<*UNUSED*> w: Xt.Widget; client_data: ADDRESS; <*UNUSED*> call_data: ADDRESS) = VAR dialog: Xt.Widget; button: Xt.Widget; pixel: INTEGER; cname: Xt.String; args := NEW (Xt.ArgList); BEGIN dialog := client_data; button := Xt.Parent (Xt.Parent (dialog)); cname := Xaw.DialogGetValueString (dialog); pixel := ConvertColor (button, cname); IF (pixel > 0) THEN args[0] := Xt.Arg {XtN.background, ItoP (pixel)}; Xt.SetValues (button, args, 1); DestroyPopupPrompt (NIL, dialog, NIL); ELSE args[0] := Xt.Arg {XtN.label, TtoS ("Can\'t get color \"" & StoT (cname) & "\". Try again.\n")}; args[1] := Xt.Arg {XtN.value, nullString}; Xt.SetValues (dialog, args, 2); END; END ColorTheButton; (* Function Name: DestroyPopupPrompt * Description: Destroys the popup dialog widget. * Arguments: w - *** UNUSED ***. * client_data - the dialog widget. This widget is a direct * child of the popup shell to destroy. * call_data - *** UNUSED **. * Returns: none. *) PROCEDURE DestroyPopupPrompt (<*UNUSED*> w: Xt.Widget; client_data: ADDRESS; <*UNUSED*> call_data: ADDRESS) = BEGIN Xt.DestroyWidget (Xt.Parent (client_data)); END DestroyPopupPrompt; (* Function Name: Ok * Description: An action routine that is invoked from any child of * the dialog widget. This routine will also color the * command button that activated the popup. * Arguments: widget - the child of the dialog that caused this action. * event, params, num_params - *** UNUSED ***. * Returns: none *) PROCEDURE Ok (w: Xt.Widget; <*UNUSED*> event: X.XEventStar; <*UNUSED*> params: Ctypes.CharStarStar; <*UNUSED*> num_params: Xt.CardinalStar) = BEGIN ColorTheButton (w, Xt.Parent (w), NIL); END Ok; (* Function Name: ConvertColor * Description: This converts a string into a color. * Arguments: color_name - name of the color. * Returns: a pixel value for that color. *) PROCEDURE ConvertColor (w: Xt.Widget; color_name: Xt.String): INTEGER = VAR pval: Ctypes.IntStar; from, to : Xrm.Value; BEGIN from.size := Cstring.strlen (color_name) + 1; from.addr := color_name; (* * This conversion accepts a colorname from rgb.txt, or a #rrrgggbbb * rgb color definition, or the special toolkit strings "XtDefaultForeground" * and "XtDefaultBackground". *) Xt.Convert (w, XtR.String, ADR (from), XtR.Pixel, ADR (to)); IF (to.addr = NIL) THEN RETURN (-1) END; pval := to.addr; RETURN (pval^) END ConvertColor; VAR fb_res := NEW (Xt.FallbackResList); actions := NEW (Xt.ActionList); app_con: Xt.AppContext; root: Xt.Widget; button: Xt.Widget; quit: Xt.Widget; box: Xt.Widget; BEGIN fb_res[0] := TtoS ("*input: True"); fb_res[1] := TtoS ("*go.label: Press to see Simple Popup Demonstration"); fb_res[2] := TtoS ("*allowShellResize: True"); fb_res[3] := TtoS ("*Dialog*value: "); fb_res[4] := TtoS ("*Dialog.label: What color should the main button be?"); fb_res[5] := TtoS ("*Dialog*value.translations: #override \\n" & " Return: Ok()"); fb_res[6] := TtoS ("*Dialog*label.resizable: TRUE"); fb_res[7] := NIL; root := Xt.AppInitialize (app_con, TtoS ("Popup"), NIL, 0, argc, argv, fb_res); IF (argc # 1) THEN Syntax (app_con, argv[0]) END; actions[0] := Xt.ActionsRec { TtoS ("Ok"), Ok}; Xt.AppAddActions (app_con, actions, 1); (* Two buttons, with callback routines, in a box. *) box := Xt.CreateManagedWidget (TtoS ("box"), Xaw.boxWidgetClass, root); button := Xt.CreateManagedWidget (TtoS ("go"),Xaw.commandWidgetClass, box); Xt.AddCallback (button, XtN.callback, PopupPrompt); quit := Xt.CreateManagedWidget (TtoS ("quit"),Xaw.commandWidgetClass, box); Xt.AddCallback (quit, XtN.callback, Quit); Xt.RealizeWidget (root); Xt.AppMainLoop (app_con); END popup.