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