XTkLabelsImpl.mesa
Copyright Ó 1988, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, October 18, 1988 11:22:01 am PDT
Christian Jacobi, April 30, 1993 4:59 pm PDT
DIRECTORY
Ascii,
Customize,
KeyMapping,
KeySymsHP,
KeySymsOSF,
KeySymsSun,
Rope,
Xl,
XlCursor,
XlCutBuffers,
XlDB,
XlFontOps,
XlPerDepth,
XTk,
XTkBlinker,
XTkCommon,
XTkDB,
XTkDelegation,
XTkFriends,
XTkLabels,
XTkLabelsExtras,
XTkOps,
XTkPrivate;
XTkLabelsImpl:
CEDAR
MONITOR
IMPORTS Customize, KeyMapping, Rope, Xl, XlCutBuffers, XlDB, XlFontOps, XlPerDepth, XTk, XTkBlinker, XTkDB, XTkDelegation, XTkFriends, XTkOps, XTkPrivate
EXPORTS XTkCommon, XTkLabels, XTkLabelsExtras
SHARES XTk, XTkFriends =
BEGIN OPEN XTkLabels;
Widget: TYPE = XTk.Widget;
WidgetSpec: TYPE = XTk.WidgetSpec;
perDKey: XlPerDepth.Handle ¬ XlPerDepth.InstallHandle[InstallDepth];
queryDBFont: PUBLIC Xl.Font ¬ Xl.OpenFont[NIL, "fake"];
labelClass:
PUBLIC XTk.Class ¬ LabClass[];
LabClass:
PROC []
RETURNS [labelClass: XTk.ImplementorClass] = {
labelClass ¬ XTkFriends.CreateClass[[
key: $Label, classNameHint: $Label,
cDataNum: 1,
wDataNum: 1,
preferredSizeLR: LabPreferredSizeLR,
actualCreateWindowLR: LabActualCreateWindowLR,
fullStopFastAccessLR: LabFullStopFastAccessLR,
initInstPart: LabelInitInstPart,
forgetScreenLR: LabelForgetScreenLR,
eventMask: [exposure: TRUE, structureNotify: TRUE, keyPress: TRUE, focusChange: TRUE],
backgroundKey: $white
]];
labelClass.cClassData[labelClass.cDataIdx] ¬
NEW[LabelClassRec ¬ [
getText: LabelGetText,
setText: LabelSetText,
getStyleSpec: LabelGetStyleSpec,
setStyleSpec: LabelSetStyleSpec,
setStyleKey: LabelSetStyleKey
]];
};
NewLabelClassPart:
PUBLIC
PROC [subClass: XTk.ImplementorClass]
RETURNS [newClassPart:
REF LabelClassRec] = {
oldClassPart: REF LabelClassRec ~ NARROW[subClass.cClassData[labelClass.cDataIdx]];
newClassPart ¬ NEW[LabelClassRec ¬ oldClassPart];
subClass.cClassData[labelClass.cDataIdx] ¬ newClassPart;
};
PerDepthRec:
TYPE =
RECORD [
actionTQ: Xl.TQ ¬ NIL, --share expose and paint threadqueues for labels of same connection
labelExtraSpace: Xl.Size ¬ [-1, -1],
grey1Pixmap, grey2Pixmap, grey3Pixmap, grey4Pixmap: Xl.Pixmap
];
stipple1Space:
REF
ARRAY [0..15]
OF
CARD32 =
NEW[
ARRAY [0..15]
OF
CARD32 ¬ [
088888888H, 0, 022222222H, 0,
088888888H, 044444444H, 022222222H, 011111111H,
CARD32.LAST, 0, 0, 0,
CARD32.LAST, 088888888H, 088888888H, 088888888H
]];
InstallDepth: XlPerDepth.InitProc = {
dd: REF PerDepthRec ¬ NEW[PerDepthRec];
IF sd#
NIL
AND Xl.Alive[sd.screen.connection]
THEN {
c: Xl.Connection ¬ sd.screen.connection;
screen: Xl.Screen ¬ sd.screen;
gc: Xl.GContext ¬ Xl.MakeGContext[c, screen.root.drawable];
Xl.SetGCGrounds[gc: gc, foreground: screen.blackPixel, background: screen.whitePixel];
dd.grey1Pixmap ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth];
dd.grey2Pixmap ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth];
dd.grey3Pixmap ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth];
dd.grey4Pixmap ¬ Xl.CreatePixmap[c, screen.root.drawable, [4, 4], sd.depth];
TRUSTED {
Xl.PutImage[c: c, drawable: dd.grey1Pixmap.drawable, gc: gc, size: [4, 4], dest: [0, 0], base: LOOPHOLE[@stipple1Space[0]], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1];
Xl.PutImage[c: c, drawable: dd.grey2Pixmap.drawable, gc: gc, size: [4, 4], dest: [0, 0], base: LOOPHOLE[@stipple1Space[4]], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1];
Xl.PutImage[c: c, drawable: dd.grey3Pixmap.drawable, gc: gc, size: [4, 4], dest: [0, 0], base: LOOPHOLE[@stipple1Space[8]], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1];
Xl.PutImage[c: c, drawable: dd.grey4Pixmap.drawable, gc: gc, size: [4, 4], dest: [0, 0], base: LOOPHOLE[@stipple1Space[12]], offx: 0, offy: 0, scanLineBytes: 4, bitsPerPixel: 1]
};
XlDB.RegisterDBInvalidator[c, InvalidateDB, NIL, dd];
};
dd.actionTQ ¬ Xl.CreateTQ[$actionTQ];
RETURN [dd]
};
InvalidateDB: Xl.EventProcType = {
dd: REF PerDepthRec ¬ NARROW[clientData];
dd.labelExtraSpace.width ¬ -1;
dd.labelExtraSpace.height ¬ -1;
};
GetDepthData:
PROC [w: XTk.Widget]
RETURNS [
REF PerDepthRec] =
INLINE {
RETURN [NARROW[XlPerDepth.InlineGetData[perDKey, w.screenDepth]]]
};
LabData: TYPE = REF LabRec;
LabRec:
TYPE =
RECORD [
text: Rope.ROPE ¬ NIL,
insertPoint: INT ¬ LAST[INT],
styleSpec: StyleSpec,
off: Xl.Point ¬ [0, 0],
gc: Xl.GContext ¬ NIL, --could we somehow share gc's?
precomputed: BOOL ¬ FALSE
];
repaintDelayed: Xl.LocalEvent ~ NEW[Xl.EventRep.local];
repaintNow: Xl.LocalEvent ~ NEW[Xl.EventRep.local];
setStyle: Xl.LocalEvent ~ NEW[Xl.EventRep.local];
setCaretPosition: Xl.LocalEvent ~ NEW[Xl.EventRep.local];
labEvents: Xl.EventFilter ~ Xl.FullCreateEventFilter[LIST[expose, keyPress, destroyNotify, focusIn, focusOut]];
LabelEventProc: <<actionTQ>>Xl.EventProcType = {
ENABLE Xl.XError, UNCAUGHT => GOTO oops;
widget: XTk.Widget ~ NARROW[clientData];
ld: LabData ~ GetInstData[widget];
IF widget.fastAccessAllowed#ok OR widget.state#realized THEN RETURN;
WITH event
SELECT
FROM
local: Xl.LocalEvent => {
SELECT local
FROM
repaintNow => ImmediateRepaint[widget, ld, immediately, event];
repaintDelayed => ImmediateRepaint[widget, ld, delayed, event];
setStyle => {
SetGCPartOfStyle[widget, ld, ld.styleSpec.styleKey];
SetWindowPartOfStyle[widget, ld, delayed];
};
setCaretPosition => ComputeCaretPosition[widget, ld];
ENDCASE => {}
};
expose: Xl.ExposeEvent => {
IF expose.count<=0 THEN ImmediateRepaint[widget, ld, delayed, event];
};
keyPress: Xl.KeyPressEvent => {
mapping: Xl.KeyboardMapping ~ Xl.GetKeyboardMapping[event.connection];
keySyms: KeyMapping.KeySyms ~ KeyMapping.GetKeySyms[mapping, keyPress.keyCode];
FOR n:
BYTE
IN [0..keySyms.n)
DO
keySym: Xl.KeySym ~ keySyms[n];
IF keySym=KeySymsSun.Copy
OR keySym=KeySymsSun.Paste
OR keySym=KeySymsHP.Copy
OR keySym=KeySymsHP.Paste
OR keySym=KeySymsOSF.Copy
OR keySym=KeySymsOSF.Paste
THEN {
CutLabelValue[widget, keyPress.state=[]];
EXIT
};
ENDLOOP
};
ev: Xl.FocusInEvent => {
SELECT ev.detail
FROM
inferior, ancestor, nonlinear => XTkBlinker.BlinkerOn[widget, $focus];
ENDCASE => {}
};
ev: Xl.FocusOutEvent => {
SELECT ev.detail
FROM
--separated only for debugging reasons
inferior => XTkBlinker.BlinkerOff[widget, $focus];
ancestor => XTkBlinker.BlinkerOff[widget, $focus];
nonlinear => XTkBlinker.BlinkerOff[widget, $focus];
ENDCASE => {}
};
destroyNotify: Xl.DestroyNotifyEvent => {
IF destroyNotify.window=widget.window
AND ~Xl.ClientRequested[event]
THEN
XTkFriends.PreStopFastAccess[widget, errorWindow]
};
ENDCASE => {};
EXITS oops => {};
};
ForkSetStyle:
PROC [widget: Widget, ld: LabData, repaint: RepaintMode ¬ immediately] = {
IF widget.fastAccessAllowed=ok
AND widget.state=realized
THEN {
dd: REF PerDepthRec ← GetDepthData[widget];
Xl.Enqueue[dd.actionTQ, LabelEventProc, widget, setStyle];
SELECT repaint
FROM
immediately => Xl.Enqueue[dd.actionTQ, LabelEventProc, widget, repaintNow];
delayed => Xl.Enqueue[dd.actionTQ, LabelEventProc, widget, repaintDelayed];
ENDCASE => {};
};
};
ForkRepaint:
PROC [widget: Widget, ld: LabData, repaint: RepaintMode ¬ immediately] = {
IF widget.fastAccessAllowed=ok
AND widget.state=realized
THEN {
dd: REF PerDepthRec ← GetDepthData[widget];
SELECT repaint
FROM
immediately => Xl.Enqueue[dd.actionTQ, LabelEventProc, widget, repaintNow];
delayed => Xl.Enqueue[dd.actionTQ, LabelEventProc, widget, repaintDelayed];
ENDCASE => {};
};
};
ForkComputeCaretPosition:
PROC [widget: Widget, ld: LabData, repaint: RepaintMode ¬ immediately] = {
IF widget.fastAccessAllowed=ok
AND widget.state=realized
THEN {
dd: REF PerDepthRec ← GetDepthData[widget];
Xl.Enqueue[dd.actionTQ, LabelEventProc, widget, setCaretPosition];
};
};
ComputeCaretPosition:
PROC [widget: Widget, ld: LabData] = {
c: Xl.Connection ¬ widget.connection;
off: Xl.Point ¬ ld.off;
text: Rope.ROPE ¬ ld.text;
charPos: INT ¬ MIN[Rope.Length[text], ld.insertPoint];
font: Xl.Font ¬ ld.styleSpec.font;
te: Xl.TextExtentsRec;
IF widget.fastAccessAllowed#ok OR widget.state#realized OR ~Xl.Alive[c] THEN RETURN;
te ¬ Xl.QueryTextExtents[c, font, Rope.Substr[text, 0, charPos] ! Xl.XError => GOTO Oops];
off.x ¬ MIN[off.x+te.overallRight, widget.actual.size.width-2];
XTkBlinker.BlinkerSetPos[widget, $focus, off];
EXITS Oops => {}
};
ImmediateRepaint:
PROC [widget: Widget, ld: LabData, repaint: XTkCommon.RepaintMode ¬ immediately, event: Xl.Event ¬
NIL] = {
c: Xl.Connection ~ widget.connection;
window: Xl.Window ~ widget.window;
IF widget.fastAccessAllowed#ok OR widget.state#realized OR ~Xl.Alive[c] THEN RETURN;
Xl.ClearArea[c, window, [0, 0], [4000, 4000], FALSE, XTkPrivate.detailsForNoErrors];
Xl.DrawRope[c, window, ld.off, ld.gc, ld.text, 0, XTkPrivate.detailsForNoErrors];
XTkFriends.CallNotifiers[widget, $LabelRepaint, NIL, event];
SELECT repaint
FROM
immediately => Xl.Flush[c];
delayed => Xl.Flush[c, TRUE];
ENDCASE => {};
};
EnforceConnection:
PROC [widget: Widget]
RETURNS [c: Xl.Connection] = {
IF widget.connection#NIL THEN RETURN [widget.connection];
IF widget.parent#NIL THEN c ¬ widget.connection ¬ EnforceConnection[widget.parent];
};
GetDefaultFont:
PUBLIC
PROC [c: Xl.Connection]
RETURNS [font: Xl.Font] = {
RETURN [XlFontOps.GetDefaultFont[c]]
};
NiceOpenFont:
PROC [c: Xl.Connection, name: Rope.
ROPE]
RETURNS [Xl.Font ¬ Xl.nullFont] = {
font: Xl.Font;
IF Rope.IsEmpty[name] OR ~Xl.Alive[c] THEN RETURN;
font ¬ Xl.OpenFont[c, name, XTkPrivate.detailsForSynchronous ! Xl.XError => GOTO Oops];
RETURN [font];
EXITS Oops => {};
};
QueryFontName:
PROC [widget: Widget]
RETURNS [Rope.
ROPE ¬
NIL] = {
WITH XTkDB.DoQueryFromWidget[w: widget, screenPrefix:
TRUE, key1: $FontName]
SELECT
FROM
r: Rope.ROPE => RETURN [r];
ENDCASE => {};
};
LocalSetFont:
PROC [widget: Widget, ld: LabData, font: Xl.Font] = {
--Any thread ok: because the critical change of state happens in single ref assignment.
IF font=queryDBFont
THEN {
fontName: Rope.ROPE ¬ QueryFontName[widget];
font ¬ NiceOpenFont[widget.connection, fontName];
};
IF font=Xl.nullFont
THEN {
val: REF ¬ XTkOps.GetWidgetPropStar[widget, $LabelFont].val;
WITH val
SELECT
FROM
r: Rope.ROPE => {font ¬ NiceOpenFont[widget.connection, r]};
ENDCASE => {IF Xl.IsFont[val] THEN font ¬ Xl.NarrowFont[val]};
IF font=queryDBFont THEN font ¬ Xl.nullFont;
IF font=Xl.nullFont THEN font ¬ XlFontOps.GetDefaultFont[widget.connection];
};
ld.styleSpec.font ¬ font;
};
defaultLabelWExtension: NAT = 3;
defaultLabelHExtension: NAT = 3;
LabPreComputations:
PROC [widget: Widget, ld: LabData] = {
connection: Xl.Connection ¬ EnforceConnection[widget];
LocalSetFont[widget, ld, ld.styleSpec.font];
--get the size
BEGIN
ext: Xl.TextExtentsRec ¬ Xl.QueryTextExtents[connection, ld.styleSpec.font, ld.text];
space: Xl.Size ¬ ld.styleSpec.space;
IF space.width<0
THEN {
dd: REF PerDepthRec ¬ GetDepthData[widget];
space.width ¬ dd.labelExtraSpace.width;
IF space.width<0
THEN {
dbx: Customize.DBreadonly ¬ XlDB.GetStandardDB[connection];
x: REF ¬ Customize.DoQueryString[dbx, "(Cedar)(defaultLabelWExtension)"];
dd.labelExtraSpace.width ¬ space.width ¬ XTkDB.ScanInt[x];
};
IF space.width<0 OR space.width>50 THEN space.width ¬ defaultLabelWExtension;
ld.styleSpec.space.width ← space.width;
};
IF space.height<0
THEN {
dd: REF PerDepthRec ¬ GetDepthData[widget];
space.height ¬ dd.labelExtraSpace.height;
IF space.height<0
THEN {
dbx: Customize.DBreadonly ¬ XlDB.GetStandardDB[connection];
x: REF ¬ Customize.DoQueryString[dbx, "(Cedar)(defaultLabelHExtension)"];
dd.labelExtraSpace.height ¬ space.height ¬ XTkDB.ScanInt[x];
};
IF space.height<0 OR space.height>50 THEN space.height ¬ defaultLabelHExtension;
ld.styleSpec.space.height ← space.height;
};
IF widget.s.geometry.size.width<=0
THEN {
widget.s.geometry.size.width ¬ 2*space.width+ext.overallLeft+ext.overallRight;
};
IF widget.s.geometry.size.height<=0
THEN {
widget.s.geometry.size.height ¬ 2*space.height+ext.fontAscent+ext.fontDescent;
};
ld.off.x ¬ space.width+ext.overallLeft;
ld.off.y ¬ space.height+ext.fontAscent;
END;
ld.precomputed ¬ TRUE;
};
LabPreferredSizeLR: XTk.PreferredSizeProc = {
ld: LabData ~ GetInstData[widget];
IF ~ld.precomputed THEN LabPreComputations[widget, ld];
RETURN [widget.s.geometry];
};
LabFullStopFastAccessLR: XTk.FullStopFastAccessProc = {
dd: REF PerDepthRec ~ GetDepthData[widget];
IF dd#NIL AND dd.actionTQ#NIL THEN protectTQLR[dd.actionTQ];
};
LabActualCreateWindowLR: XTk.WidgetProc = {
dd: REF PerDepthRec ~ GetDepthData[widget];
ld: LabData ~ GetInstData[widget];
IF ~ld.precomputed THEN LabPreComputations[widget, ld];
XTk.AddTemporaryMatch[widget, [proc: LabelEventProc, handles: labEvents, tq: dd.actionTQ, data: widget], labelClass.eventMask];
IF widget.attributes.bitGravity=illegal
THEN
widget.attributes.bitGravity ¬ northWest;
ld.gc ¬ Xl.MakeGContext[widget.connection, widget.parent.window.drawable];
Xl.SetGCFont[ld.gc, ld.styleSpec.font]; --is available since precomputed!
Xl.SetGCGraphicsExposures[ld.gc, FALSE];
SetGCPartOfStyle[widget, ld, ld.styleSpec.styleKey];
XTkFriends.DontMapCreateWindowLR[widget];
IF ld.styleSpec.styleKey#NIL THEN SetWindowPartOfStyle[widget, ld, dont];
IF widget.actualMapping=mapped
THEN
Xl.MapWindow[widget.connection, widget.window];
ForkComputeCaretPosition[widget, ld];
};
focusBlinkerClass: XTkBlinker.BlinkerClass ¬ XTkBlinker.NewBlinkerClass[createProc: CreateFocusBlinker];
CreateFocusBlinker: XTkBlinker.CreateOverlayProc = {
myGeometry: Xl.Geometry ~ [pos: [pos.x, pos.y], size: [4, 6], borderWidth: 0];
sd: Xl.ScreenDepth ~ parent.screenDepth;
attributes.backgroundPixel ¬ sd.screen.blackPixel;
geometry ¬ [pos: [0, 0], size: [4, 6], borderWidth: 0];
w ¬ Xl.CreateWindow[c: parent.connection, matchList: NIL, parent: parent.window, class: inputOutput, geometry: myGeometry, attributes: attributes];
};
LabelInitInstPart: XTk.InitInstancePartProc = {
ld: LabData ~ NEW[LabRec];
XTkFriends.AssignInstPart[widget, labelClass, ld];
XTkBlinker.InstallBlinker[widget, $focus, focusBlinkerClass, FALSE];
};
LabelForgetScreenLR: XTk.TerminateProc = {
ld: LabData ~ GetInstData[widget];
ld.precomputed ¬ FALSE; ld.gc ¬ NIL;
ld.styleSpec.font ¬ Xl.nullFont;
};
CreateLabel:
PUBLIC
PROC [widgetSpec: WidgetSpec, text: Rope.
ROPE ¬
NIL, style: StyleSpec ¬ []]
RETURNS [Widget] = {
widget: Widget ~ XTk.CreateWidget[widgetSpec, labelClass];
ld: LabData ~ GetInstData[widget];
ld.text ¬ text;
ld.styleSpec ¬ style;
RETURN [widget]
};
GetInstData:
PROC [w: Widget]
RETURNS [LabData] =
INLINE {
RETURN [NARROW[XTkFriends.InstPart[w, labelClass]]];
};
GetLabelClassPart:
PROC [w: Widget]
RETURNS [
REF LabelClassRec] =
INLINE {
RETURN [NARROW[XTkFriends.ClassPart[w, labelClass]]]
};
GetText:
PUBLIC
PROC [widget: Widget]
RETURNS [text: Rope.
ROPE] = {
w: Widget ~ XTkDelegation.InlineSingleDelegant[widget, labelClass.key, $TextDelegation];
RETURN [GetLabelClassPart[w].getText[w]];
};
LabelGetText:
PROC [widget: Widget]
RETURNS [text: Rope.
ROPE] = {
RETURN [GetInstData[widget].text];
};
SetText:
PUBLIC
PROC [widget: Widget, text: Rope.
ROPE, repaint: RepaintMode ¬ immediately] = {
w: Widget ~ XTkDelegation.InlineSingleDelegant[widget, labelClass.key, $TextDelegation];
GetLabelClassPart[w].setText[w, text, repaint];
};
LabelSetText:
PROC [widget: Widget, text: Rope.
ROPE, repaint: RepaintMode] = {
Any thread ok: since actual action is single ref assignment.
ld: LabData ~ GetInstData[widget];
ld.text ¬ text;
IF repaint#dont THEN ForkRepaint[widget, ld, delayed];
ForkComputeCaretPosition[widget, ld];
};
EntrySetStyleSpec:
ENTRY
PROC [ld: LabData, style: StyleSpec] = {
IF ld#NIL THEN ld.styleSpec ¬ style
EntryGetStyleSpec:
ENTRY
PROC [ld: LabData]
RETURNS [style: StyleSpec] = {
IF ld#NIL THEN style ¬ ld.styleSpec
};
SetGCPartOfStyle:
PROC [widget: XTk.Widget, ld: LabData, style:
ATOM] = {
screen: Xl.Screen ~ widget.screenDepth.screen;
Xl.SetGCFillStyle[ld.gc, solid];
SELECT style
FROM
NIL => {
Xl.SetGCForeground[ld.gc, screen.blackPixel];
Xl.SetGCBackground[ld.gc, screen.whitePixel];
};
$invert, $WhiteOnBlack => {
Xl.SetGCForeground[ld.gc, screen.whitePixel];
Xl.SetGCBackground[ld.gc, screen.blackPixel];
};
ENDCASE => {
Xl.SetGCForeground[ld.gc, screen.blackPixel];
Xl.SetGCBackground[ld.gc, screen.whitePixel];
};
};
GetStyleSpec:
PUBLIC
PROC [widget: Widget]
RETURNS [style: StyleSpec] = {
w: Widget ~ XTkDelegation.InlineSingleDelegant[widget, labelClass.key, $TextDelegation];
ld: LabData ~ GetInstData[w];
RETURN [EntryGetStyleSpec[ld]];
};
SetStyleSpec:
PUBLIC
PROC [widget: Widget, style: StyleSpec, repaint: RepaintMode ¬ immediately] = {
Any thread ok: defer to class implementors.
Tries delegations, and, tries subclassed procedures.
MultiDelegation: PROC [delegant: Widget] = {SetStyleSpec[delegant, style, dont]};
IF XTkDelegation.InlineDidMultiDelegation[widget, labelClass.key, $TextDelegationSetStyle, MultiDelegation]
THEN {
SELECT repaint
FROM
immediately => Xl.Flush[widget.connection];
delayed => Xl.Flush[widget.connection, TRUE];
ENDCASE => {};
}
ELSE {
GetLabelClassPart[widget].setStyleSpec[widget, style, repaint];
}
};
SetStyleKey:
PUBLIC
PROC [widget: Widget, styleKey:
ATOM, repaint: RepaintMode ¬ immediately] = {
Any thread ok: defer to class implementors.
Tries delegations, and, tries subclassed procedures.
MultiDelegation: PROC [delegant: Widget] = {SetStyleKey[delegant, styleKey, dont]};
IF XTkDelegation.InlineDidMultiDelegation[widget, labelClass.key, $TextDelegationSetStyle, MultiDelegation]
THEN {
SELECT repaint
FROM
immediately => Xl.Flush[widget.connection];
delayed => Xl.Flush[widget.connection, TRUE];
ENDCASE => {};
}
ELSE {
GetLabelClassPart[widget].setStyleKey[widget, styleKey, repaint];
}
};
LabelSetStyleKey:
PROC [widget: Widget, style:
ATOM, repaint: RepaintMode ¬ immediately] = {
ld: LabData ~ GetInstData[widget];
ld.styleSpec.styleKey ¬ style;
IF repaint#dont THEN ForkSetStyle[widget, ld, repaint];
};
LabelGetStyleSpec:
PROC [widget: Widget]
RETURNS [style: StyleSpec] = {
ld: LabData ~ GetInstData[widget];
style ¬ EntryGetStyleSpec[ld];
};
LabelSetStyleSpec:
PROC [widget: Widget, style: StyleSpec, repaint: RepaintMode ¬ immediately] = {
ld: LabData ~ GetInstData[widget];
EntrySetStyleSpec[ld, style];
IF repaint#dont THEN ForkSetStyle[widget, ld, repaint];
};
SetWindowPartOfStyle:
PROC [widget: Widget, ld: LabData, repaint: RepaintMode ¬ immediately] = {
dd: REF PerDepthRec ~ GetDepthData[widget];
SELECT ld.styleSpec.styleKey
FROM
NIL, $BlackOnWhite => {
Xl.ChangeWindowAttributes[c: widget.connection, window: widget.window, attributes: [backgroundPixel: widget.screenDepth.screen.whitePixel], details: XTkPrivate.detailsForNoErrors];
};
$invert, $WhiteOnBlack => {
Xl.ChangeWindowAttributes[c: widget.connection, window: widget.window, attributes: [backgroundPixel: widget.screenDepth.screen.blackPixel], details: XTkPrivate.detailsForNoErrors];
};
$BlackOnGray, $Gray1 => {
Xl.ChangeWindowAttributes[c: widget.connection, window: widget.window, attributes: [backgroundPixmap: dd.grey1Pixmap], details: XTkPrivate.detailsForNoErrors];
};
$Gray2 => {
Xl.ChangeWindowAttributes[c: widget.connection, window: widget.window, attributes: [backgroundPixmap: dd.grey2Pixmap], details: XTkPrivate.detailsForNoErrors];
};
$Gray3 => {
Xl.ChangeWindowAttributes[c: widget.connection, window: widget.window, attributes: [backgroundPixmap: dd.grey3Pixmap], details: XTkPrivate.detailsForNoErrors];
};
$Gray4 => {
Xl.ChangeWindowAttributes[c: widget.connection, window: widget.window, attributes: [backgroundPixmap: dd.grey4Pixmap], details: XTkPrivate.detailsForNoErrors];
};
ENDCASE => {};
};
CutLabelValue:
PROC [label: XTk.Widget, hackForXTerm:
BOOL ¬
FALSE] = {
text: Rope.ROPE ~ GetText[label];
XlCutBuffers.Put[label.connection, text];
};
SetCharInsertionIndex:
PUBLIC
PROC [label: XTk.Widget, pos:
INT, repaint: RepaintMode ¬ immediately] = {
c: Xl.Connection ~ label.connection;
ld: LabData ~ GetInstData[label];
ld.insertPoint ¬ pos;
IF Xl.Alive[c]
THEN {
dd: REF PerDepthRec ~ GetDepthData[label];
Xl.Enqueue[dd.actionTQ, LabelEventProc, label, setCaretPosition];
};
};
SetCharInsertionPos:
PUBLIC
PROC [label: XTk.Widget, pos: Xl.Point, repaint: RepaintMode ¬ immediately] = {
i: INT ¬ ToCharPos[label, pos];
SetCharInsertionIndex[label, i, repaint];
};
GetCharInsertionIndex:
PUBLIC
PROC [label: XTk.Widget]
RETURNS [pos:
INT] = {
ld: LabData ~ GetInstData[label];
RETURN [ld.insertPoint]
};
ToCharPos:
PUBLIC
PROC [label: XTk.Widget, pos: Xl.Point]
RETURNS [cpos:
INT ¬ 0] = {
ENABLE Xl.XError => GOTO Oops;
ld: LabData ~ GetInstData[label];
c: Xl.Connection ¬ label.connection;
font: Xl.Font ¬ ld.styleSpec.font;
IF label.fastAccessAllowed#ok OR label.state#realized OR ~Xl.Alive[c] THEN RETURN;
cpos ¬ XlFontOps.QueryPosInfo[c, font, ld.text, pos.x-ld.off.x].gapIndex;
EXITS Oops => {}
};
END.