X11PopUpSelectionImplTk.mesa
Copyright Ó 1988, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, April 21, 1988 2:49:13 pm PDT
Christian Jacobi, March 9, 1992 4:29 pm PST
DIRECTORY
Process,
Rope,
X11PopUpSelection,
Xl,
XlCursor,
XTk,
XTkFriends,
XTkWidgets;
X11PopUpSelectionImplTk: CEDAR MONITOR
IMPORTS Process, Rope, Xl, XlCursor, XTkFriends, XTkWidgets
EXPORTS X11PopUpSelection
~ BEGIN OPEN Xl, XTk, XTkWidgets, X11PopUpSelection;
lastRefInt: INT = 9;
ri: REF ARRAY [0..lastRefInt] OF REF INT = NEW[ARRAY [0..lastRefInt] OF REF INT];
NewInt: PROC [i: INT] RETURNS [REF INT] = {
--caller trusts that nobody did change referee's int value
--caller promises that he won't change referee's int value
IF i>=0 AND i<=lastRefInt THEN RETURN [ri[i]];
RETURN [NEW[INT¬i]];
};
ROPE: TYPE = Rope.ROPE;
gConnection: Xl.Connection ¬ NIL;
cond: CONDITION;
PositionAndScreen: PROC [connection: Xl.Connection] RETURNS [pos: Point, s: Screen] = {
pointerQuery: PointerReply ¬ QueryPointer[connection, nullWindow];
pos ¬ pointerQuery.pos;
s ¬ QueryScreen[connection, pointerQuery.root];
IF s=NIL THEN s ¬ FirstScreen[connection]
};
MakeConnection: ENTRY PROC [] RETURNS [c: Xl.Connection] = {
ENABLE UNWIND => NULL;
c ¬ gConnection;
IF ~Xl.Alive[c] THEN c ¬ gConnection ¬ Xl.CreateConnection[server: NIL];
};
MenuRec: TYPE = RECORD [
shell: XTk.Widget ¬ NIL,
allDone: BOOL ¬ FALSE,
selection: INT ¬ -1
];
ReCheck: ENTRY PROC [] = {
ENABLE UNWIND => NULL;
BROADCAST cond
};
WaitDone: ENTRY PROC [menu: REF MenuRec] = {
ENABLE UNWIND => NULL;
DO
IF menu.allDone THEN RETURN;
IF menu.shell.fastAccessAllowed#ok THEN RETURN;
IF ~Xl.Alive[menu.shell.connection] THEN RETURN;
WAIT cond;
ENDLOOP;
};
Hit: XTkWidgets.ButtonHitProcType = {
menu: REF MenuRec ¬ NARROW[registerData];
menu.selection ¬ NARROW[callData, REF INT]­;
menu.allDone ¬ TRUE;
ReCheck[];
};
mySpace: Xl.Size = [5, 3];
Request: PUBLIC PROC [
header: Rope.ROPE ¬ NIL, choice: LIST OF Rope.ROPE,
headerDoc: Rope.ROPE ¬ NIL, choiceDoc: LIST OF Rope.ROPE ¬ NIL,
default: NAT ¬ 0, timeOut: NAT ¬ 0, position: REF ¬ NIL,
connection: REF ¬ NIL
] RETURNS [INT] = {
c: Xl.Connection ¬ NIL; transientFor: XTk.Widget ¬ NIL;
point: Xl.Point; screen: Xl.Screen; container: XTk.Widget; i: INT ¬ 0;
choiceCursor, backCursor: Xl.Cursor;
menu: REF MenuRec ¬ NEW[MenuRec];
WITH connection SELECT FROM
w: XTk.Widget => {c ¬ w.connection; transientFor ¬ w};
connection: Xl.Connection => c ¬ connection;
ENDCASE => c ¬ gConnection;
IF ~Xl.Alive[c] THEN c ¬ MakeConnection[];
choiceCursor ¬ XlCursor.SharedStandardCursor[c, sbLeftArrow];
backCursor ¬ XlCursor.SharedStandardCursor[c, circle];
[point, screen] ¬ PositionAndScreen[c];
container ¬ XTkWidgets.CreateYStack[];
container.attributes.cursor ¬ backCursor;
menu.shell ¬ XTkWidgets.CreateShell[
widgetSpec: [geometry: Xl.Geometry[pos: point]],
windowHeader: """popup"" menu",
child: container,
dontQueryGeometry: TRUE
];
XTkWidgets.BindScreenShell[menu.shell, c, screen.root];
IF ~Rope.IsEmpty[header] THEN {
hw: Widget ¬ XTkWidgets.CreateLabel[text: header, style: [styleKey: $WhiteOnBlack]];
XTkWidgets.AppendChild[container: container, child: hw]
};
FOR cl: LIST OF Rope.ROPE ¬ choice, cl.rest WHILE cl#NIL DO
help: Rope.ROPE ¬ IF choiceDoc=NIL THEN NIL ELSE choiceDoc.first;
entry: Widget ¬ XTkWidgets.CreateButton[text: cl.first, style: [space: mySpace], hitProc: Hit, registerData: menu, callData: NewInt[(i¬i+1)], help: help];
entry.attributes.cursor ¬ choiceCursor;
XTkWidgets.AppendChild[container: container, child: entry];
IF choiceDoc#NIL THEN choiceDoc ¬ choiceDoc.rest;
ENDLOOP;
BEGIN
entry: Widget ¬ XTkWidgets.CreateButton[text: "DISCARD MENU", style: [space: mySpace], hitProc: Hit, registerData: menu, callData: NewInt[0], help: "no action"];
entry.attributes.cursor ¬ choiceCursor;
XTkWidgets.AppendChild[container: container, child: entry];
END;
BEGIN
compensate: Size ~ [-1, -10]; --compensate for window manager decorations
preferred: Xl.Geometry ¬ XTkFriends.PreferredSizeLR[menu.shell]; --not yet realized!
szh: REF ICCCMHints ¬ XTkWidgets.GetHints[menu.shell];
szh.wmNormalHints.userPos ¬ szh.wmNormalHints.clientPos ¬ TRUE;
szh.wmNormalHints.userSize ¬ szh.wmNormalHints.clientSize ¬ TRUE;
szh.transientFor ¬ transientFor;
point.x ¬ MAX[MIN[point.x, screen.sizeInPixels.width - preferred.size.width - compensate.width], 0];
point.y ¬ MAX[MIN[point.y, screen.sizeInPixels.height - preferred.size.height - compensate.height], 0];
menu.shell.s.geometry.pos ¬ point;
szh.wmNormalHints.obsoletePos ¬ point;
szh.wmNormalHintsChanged ¬ TRUE;
szh.transientForChanged ¬ TRUE;
END;
XTkWidgets.RealizeShell[menu.shell];
WaitDone[menu];
XTkWidgets.DestroyShell[menu.shell];
RETURN [menu.selection];
};
InitModule: ENTRY PROC = TRUSTED {
ENABLE UNWIND => NULL;
FOR i: INT IN [0..lastRefInt] DO ri[i] ¬ NEW[INT¬i] ENDLOOP;
Process.InitializeCondition[@cond, Process.MsecToTicks[10000]];
};
InitModule[];
END.