XTkButtonsImpl.mesa
Copyright Ó 1991, 1992 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, July 2, 1991 1:58 pm PDT
Christian Jacobi, March 10, 1992 2:14 pm PST
Implements a button widget class.
A button is a label with a callback procedure.
DIRECTORY
HelpStrings,
Process USING [Detach],
Rope USING [ROPE],
Xl,
XlCursor USING [StandardFontCursors],
XTk,
XTkButtons,
XTkFriends USING [AssignInstPart, CreateClass, InheritedConfigureLRProc, InitClassField, InstPart],
XTkHelpStrings,
XTkLabels;
XTkButtonsImpl: CEDAR MONITOR
IMPORTS HelpStrings, Process, Xl, XTk, XTkFriends, XTkHelpStrings, XTkLabels
EXPORTS XTkButtons
SHARES XTk, XTkFriends =
BEGIN OPEN XTkButtons;
isPopUpFlag: XTk.WidgetFlagKey ~ wf3;
Widget: TYPE = XTk.Widget;
WidgetSpec: TYPE = XTk.WidgetSpec;
RepaintMode: TYPE = XTkLabels.RepaintMode;
buttonClass: PUBLIC XTk.Class ¬ ButtonClass[];
ButtonClass: PROC [] RETURNS [buttonClass: XTk.ImplementorClass] = {
buttonClass ¬ XTkFriends.CreateClass[[
key: $but, classNameHint: $Button, super: XTkLabels.labelClass, wDataNum: 1,
configureLR: ButtonConfigureLR,
initInstPart: ButtonInitInstPart,
eventMask: butMask,
cursorKey: NEW[XlCursor.StandardFontCursors ¬ target]
]];
BEGIN
labelClassPart: REF XTkLabels.LabelClassRec ~ XTkLabels.NewLabelClassPart[buttonClass];
superGetStyleSpec ¬ labelClassPart.getStyleSpec;
superSetStyleSpec ¬ labelClassPart.setStyleSpec;
superSetStyleKey ¬ labelClassPart.setStyleKey;
labelClassPart.getStyleSpec ¬ ButtonGetStyleSpec;
labelClassPart.setStyleSpec ¬ ButtonSetStyleSpec;
labelClassPart.setStyleKey ¬ ButtonSetStyleKey;
END;
buttonInheritConfigureLR ¬ XTkFriends.InheritedConfigureLRProc[buttonClass.super];
};
superGetStyleSpec: XTkLabels.GetStyleSpecProc;
superSetStyleSpec: XTkLabels.SetStyleSpecProc;
superSetStyleKey: XTkLabels.SetStyleKeyProc;
buttonInheritConfigureLR: XTk.ConfigureProc;
butMask: Xl.SetOfEvent ~ [buttonPress: TRUE, buttonRelease: TRUE, structureNotify: TRUE, enterWindow: TRUE, leaveWindow: TRUE];
butEvents: Xl.EventFilter ~ Xl.CreateEventFilter[buttonPress, buttonRelease, leaveNotify, enterNotify];
buttonListening: ATOM ~ $WhiteOnBlack;
buttonRunning: ATOM ~ $BlackOnGray;
ButData: TYPE = REF ButRec;
ButRec: TYPE = RECORD [
widget: Widget ¬ NIL,
help: Rope.ROPE ¬ NIL,
helpHandle: HelpStrings.Handle ¬ NIL,
hitTQ: Xl.TQ ¬ NIL,
callbackRec: CallbackRec ¬ [],
hitProcessing: BOOL ¬ FALSE,
hereDown: BOOL ¬ FALSE,
inside: BOOL ¬ FALSE,
originalStyleKey: ATOM ¬ NIL
];
CallbackRec: TYPE = RECORD [
hitProc: XTk.WidgetNotifyProc ¬ NIL,
registerData, callData: REF ¬ NIL
];
EntrySetCallbackRec: ENTRY PROC [bd: ButData, cbr: CallbackRec] = {
IF bd#NIL THEN bd.callbackRec ¬ cbr
};
EntryGetCallbackRec: ENTRY PROC [bd: ButData] RETURNS [cbr: CallbackRec] = {
IF bd#NIL THEN RETURN [bd.callbackRec]
};
GetButtonData: PROC [w: Widget] RETURNS [ButData] = INLINE {
RETURN [NARROW[XTkFriends.InstPart[w, buttonClass]]];
};
ButtonSetStyleKey: PROC [widget: Widget, style: ATOM, repaint: RepaintMode] = {
bd: ButData ~ GetButtonData[widget];
bd.originalStyleKey ¬ style;
superSetStyleKey[widget, style, repaint];
};
ButtonGetStyleSpec: PROC [widget: Widget] RETURNS [style: StyleSpec] = {
bd: ButData ~ GetButtonData[widget];
style ¬ superGetStyleSpec[widget];
style.styleKey ¬ bd.originalStyleKey
};
ButtonSetStyleSpec: PROC [widget: Widget, style: StyleSpec, repaint: RepaintMode] = {
bd: ButData ~ GetButtonData[widget];
bd.originalStyleKey ¬ style.styleKey;
superSetStyleSpec[widget, style, repaint];
};
ButtonEventProc: Xl.EventProcType = {
bd: ButData ~ NARROW[clientData];
IF bd.widget.fastAccessAllowed#ok THEN {--has been destroyed
bd.inside ¬ FALSE;
RETURN;
};
SELECT event.type FROM
buttonPress => {
ev: Xl.ButtonPressEvent ~ NARROW[event];
bd.inside ¬ TRUE;
IF ev.state.button1 OR ev.state.button2 OR ev.state.button3 OR ev.state.button4 OR ev.state.button5 THEN RETURN;
IF ~bd.hitProcessing AND Xl.SetButtonGrabOwner[ev.connection, ev.timeStamp, bd]=succeeded THEN {
bd.hereDown ¬ TRUE;
superSetStyleKey[bd.widget, buttonListening, immediately];
HelpStrings.Display[bd.helpHandle, bd.help];
};
};
buttonRelease => {
ev: Xl.ButtonReleaseEvent ~ NARROW[event];
sz: Xl.Size ¬ bd.widget.actual.size;
IF ~bd.hereDown THEN RETURN;
bd.hereDown ¬ FALSE;
IF bd.hitProcessing THEN RETURN;
HelpStrings.Clear[bd.helpHandle, bd.help];
IF ev.pos.x<0 OR ev.pos.y<0 OR ev.pos.x>=sz.width OR ev.pos.y>=sz.height OR ~bd.inside THEN {
superSetStyleKey[bd.widget, bd.originalStyleKey, immediately];
RETURN;
};
bd.hitProcessing ¬ TRUE;
superSetStyleKey[bd.widget, buttonRunning, immediately];
IF bd.hitTQ=NIL
THEN TRUSTED {Process.Detach[FORK EnvelopeProc[ev, bd, NIL]]}
ELSE Xl.Enqueue[bd.hitTQ, EnvelopeProc, bd, ev];
};
leaveNotify => {
bd.inside ¬ FALSE;
IF ~bd.hitProcessing AND bd.hereDown THEN {
superSetStyleKey[bd.widget, bd.originalStyleKey, immediately];
HelpStrings.Clear[bd.helpHandle, bd.help];
};
};
enterNotify => {
bd.inside ¬ TRUE;
IF ~bd.hitProcessing AND bd.hereDown THEN {
superSetStyleKey[bd.widget, buttonListening, immediately];
HelpStrings.Display[bd.helpHandle, bd.help];
};
};
ENDCASE => {};
};
EnvelopeProc: Xl.EventProcType = {
bd: ButData ~ NARROW[clientData];
cbr: CallbackRec ~ EntryGetCallbackRec[bd];
cbr.hitProc[event: event, widget: bd.widget, registerData: cbr.registerData, callData: cbr.callData ! ABORTED => CONTINUE];
superSetStyleKey[bd.widget, bd.originalStyleKey, immediately];
bd.hitProcessing ¬ FALSE;
};
ImplementorHitTQ: PROC [w: XTk.Widget] RETURNS [tq: Xl.TQ] = {
Share hit threads to reduce memory allocations...
x: REF ~ Xl.GetConnectionProp[w.connection, $XTkButtonsImpl];
IF Xl.IsTQ[x] THEN RETURN [Xl.NarrowTQ[x]];
IF x=NIL THEN {
tq ¬ Xl.CreateTQ[];
Xl.PutConnectionProp[w.connection, $XTkButtonsImpl, tq]
}
};
ButtonConfigureLR: XTk.ConfigureProc = {
createW: BOOL ~ mapping<unconfigured AND widget.actualMapping>=unconfigured;
IF createW THEN {
bd: ButData ~ GetButtonData[widget];
XTk.AddTemporaryMatch[widget, [proc: ButtonEventProc, handles: butEvents, tq: ImplementorHitTQ[widget], data: bd], butMask];
IF XTk.GetWidgetFlag[XTk.RootWidget[widget], isPopUpFlag] THEN bd.hereDown ¬ TRUE;
bd.helpHandle ¬ XTkHelpStrings.GetHandle[XTk.RootWidget[widget]];
};
buttonInheritConfigureLR[widget, geometry, mapping, reConsiderChildren];
};
NilHit: XTk.WidgetNotifyProc = {
--allows to avoid a NIL check when calling the hit-proc
};
ButtonInitInstPart: XTk.InitInstancePartProc = {
bd: ButData ~ NEW[ButRec];
bd.widget ¬ widget;
bd.callbackRec.hitProc ¬ NilHit;
XTkFriends.AssignInstPart[widget, buttonClass, bd];
};
CreateButton: PUBLIC PROC [widgetSpec: WidgetSpec, text: Rope.ROPE ¬ NIL, style: StyleSpec ¬ [], hitProc: XTk.WidgetNotifyProc, registerData, callData: REF ¬ NIL, hitTQ: Xl.TQ ¬ NIL, help: Rope.ROPE ¬ NIL] RETURNS [widget: TextWidget] = {
widgetSpec.class ¬ XTkFriends.InitClassField[widgetSpec.class, buttonClass];
widget ¬ XTkLabels.CreateLabel[widgetSpec, text, style];
BEGIN
bd: ButData ~ GetButtonData[widget];
bd.originalStyleKey ¬ style.styleKey;
bd.hitTQ ¬ hitTQ;
bd.help ¬ help
END;
SetButtonCallback[widget, hitProc, registerData, callData];
};
SetButtonTQ: PUBLIC PROC [button: XTk.Widget, hitTQ: Xl.TQ ¬ NIL] = {
bd: ButData ~ GetButtonData[button];
bd.hitTQ ¬ hitTQ
};
SetButtonHelp: PUBLIC PROC [button: XTk.Widget, help: Rope.ROPE ¬ NIL] = {
bd: ButData ~ GetButtonData[button];
bd.help ¬ help
};
SetButtonCallback: PUBLIC PROC [button: XTk.Widget, hitProc: XTk.WidgetNotifyProc ¬ NIL, registerData, callData: REF ¬ NIL] = {
bd: ButData ~ GetButtonData[button];
IF bd#NIL THEN {
IF hitProc=NIL THEN hitProc ¬ NilHit;
EntrySetCallbackRec[bd, [hitProc: hitProc, registerData: registerData, callData: callData]];
};
};
END.