
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] = {
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 = {
};

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.


  Д  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.


Share hit threads to reduce memory allocations...
--allows to avoid a NIL check when calling the hit-proc


 Э╩┘  ХNewlineDelimiter
Ц(cedarcode) styleШ codeЪЬЩKЪЬ
╧eЬ7ЩBKЪЬ5Щ5KЪЬ,Щ,KЩ ЪЬ"╧cЩ#KЪЮЬ Щ.ЧKЩ ЧЪ╧k	ЬШ
KЪЬШKЪЬЯЬ
ШKЪЬЯЬЯЬШKЪЬШKЪЬ	ЯЬШ%KЪЬШKЪЬШKЪЬЯЬSШcKЪЬШKЪЬ
Ш
KШ ЧЪ╧nЬЯЬЯШKЪЯЬEШLKЪЯЬШKЪЯЬШЧKЪЯЬЯЬШKШ KЪЬ%Ш%KШ KЪЬЯЬШKЪЬЯЬШ"KЪЬЯЬШ*KШ ЪЬЯЬШ.ЪаЬЯЬЯЬ(ШDЪЬ&Ш&KЪЬMШMKЪЬ Ш KЪЬ"Ш"KЪЬШKЪЬЯЬ'Ш5KЪЬШЧЪЯШKЪЬЯЬDШWKЪЬ0Ш0KЪЬ0Ш0KЪЬ.Ш.KЪЬ1Ш1KЪЬ1Ш1KЪЬ/Ш/KЪЯЬШЧKЪЬRШRKЪЬШЧЧKШ KЪЬ.Ш.KЪЬ.Ш.KЪЬ,Ш,KЪЬ,Ш,KШ KЪЬ'ЯЬЯЬЯЬЯЬЯЬШKЪЬgШgKШ KЪЬЯЬШ'KЪЬЯЬШ$KЩ KЪЬ	ЯЬЯЬШЪЬЯЬЯЬШKЪЬЯЬШKЪЬЯЬЯЬШKЪЬ!ЯЬШ%KЪЬ
ЯЬЯЬШKЪЬШKЪЬЯЬЯЬШKЪЬ
ЯЬЯЬШKЪЬЯЬЯЬШKЪЬЯЬЯШKЪЬШЧKШ ЪЬЯЬЯЬШKЪЬ ЯЬШ$KЪЬЯЬЯШ!KШKШ ЧЪаЬЯЬЯЬ$ШCKЪЯЬЯЬЯЬШ#KШЧKШ ЪаЬЯЬЯЬЯЬШLKЪЯЬЯЬЯЬЯЬШ&KШЧKШ ЪаЬЯЬЯЬЯЬШ<KЪЯЬЯЬ'Ш5KЪЬШЧKШ ЪаЬЯЬЯЬШOKЪЬ$Ш$KЪЬШKЪЬ)Ш)KШЧKШ ЪаЬЯЬЯЬШHKЪЬ$Ш$KЪЬ"Ш"KЪЬ$Ш$KЪЬШЧKШ ЪаЬЯЬ=ШUKЪЬ$Ш$KЪЬ%Ш%KЪЬ*Ш*KШЧKЩ ЪаЬШ%KЪЬЯЬШ!ЪЯЬ ЯЬЯЮШ<KЪЬЯЬШKЪЯЬШKШЧЪЯЬЯШЪЬШKЪЬЯЬШ(KЪЬЯЬШKЪЯЬЯЬЯЬЯЬЯЬЯЬЯЬШpЪЯЬЯЬBЯЬШ`KЪЬЯЬШKЪЬ:Ш:KЪЬ,Ш,KШЧKШЧЪЬШKЪЬЯЬШ*KЪЬ$Ш$KЪЯЬЯЬЯЬШKЪЬЯЬШKЪЯЬЯЬЯЬШ KЪЬ*Ш*ЪЯЬЯЬЯЬЯЬЯЬЯЬШ]KЪЬ>Ш>KЪЯЬШKШЧKЪЬЯЬШKЪЬ8Ш8ЪЯЬ
ЯЬШKЪЯЬЯЬЯЬЯЬШ=KЪЯЬ,Ш0ЧKЪЬШЧЪЬШKЪЬЯЬШЪЯЬЯЬЯЬШ,KЪЬ>Ш>KЪЬ*Ш*KШЧKШЧЪЬШKЪЬЯЬШЪЯЬЯЬЯЬШ,KЪЬ:Ш:KЪЬ,Ш,KШЧKШЧKЪЯЬШЧKШЧKШ ЪаЬШ"KЪЬЯЬШ!KЪЬ+Ш+KЪЬfЯЬЯЬШ{KЪЬ>Ш>KЪЬЯЬШKШKШ ЧЪаЬЯЬЯЬ	ЯЬШ>KЪЬ1Щ1KЪЬЯЬ7Ш=KЪЯЬЯЬЯЬШ+ЪЯЬЯЬЯЬШKЪЬШKЪЬ7Ш7KЪЬШЧKЪЬШЧKШ ЪаЬШ(KЪЬ	ЯЬЯЬ$ШLЪЯЬ	ЯЬШKЪЬ$Ш$KЪЬ|Ш|KЪЯЬ8ЯЬЯЬШRKЪЬAШAKШЧKЪЬHШHKЪЬШЧKШ ЪаЬШ KЪЮ7Щ7KЪЬШKШ ЧЪаЬШ0KЪЬЯЬ	ШKЪЬШKЪЬ Ш KЪЬ3Ш3KШЧKШ ЪаЬЯЬЯЬ%ЯЬЯЬPЯЬЯЬЯЬЯЬЯЬЯЬЯЬШюKЪЬLШLKЪЬ8Ш8ЪЯШKЪЬ$Ш$KЪЬ%Ш%KЪЬШKЪЬШKЪЯЬШЧKЪЬ;Ш;KЪЬШKШ ЧЪ
аЬЯЬЯЬ ЯЬЯЬШEKЪЬ$Ш$KЪЬШKЪЬШKЩ ЧЪ
аЬЯЬЯЬ!ЯЬЯЬШJKЪЬ$Ш$KЪЬШKЪЬШKЩ ЧЪаЬЯЬЯЬ6ЯЬЯЬЯЬШKЪЬ$Ш$ЪЯЬЯЬЯЬШKЪЯЬ	ЯЬЯЬШ%KЪЬ\Ш\KШЧKШЧKЪЯЬШKШ KШ Ч ЕЧ    └  '  