X11ViewersImpl.mesa
Copyright Ó 1988, 1989, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, November 22, 1988
Bier, January 26, 1989 11:15:06 pm PST
Christian Jacobi, August 20, 1993 12:41 pm PDT
Michael Plass, February 25, 1992 4:05 pm PST
Willie-s, March 18, 1992 3:44 pm PST
Last tweaked by Mike Spreitzer March 26, 1992 3:57 pm PST
DIRECTORY
Atom, BasicTime, Buttons, Commander, CommanderOps, Customize, HelpStrings, ForkOps, Identification, Imager, ImagerColor, ImagerSample, InputFocus, IO, MessageWindow, Process, Rope, RuntimeError, SF, SystemNames, SystemVersion, UserInput, ViewerClasses, ViewerEvents, ViewerHelpStrings, ViewerOps, ViewerScreenTypes, ViewersWorld, ViewersWorldClasses, X11Viewers, X11ViewersAccess, ViewersWorldInitializations, X11ViewersInstance, Xl, XlBitmap, XlDB, XlPredefinedAtoms, XlShmPixmaps, XlTQPrivate, XTk, XTkBitmapWidgets, XTkNotification, XTkPopUps, XTkTIPSource, XTkShellWidgets;
X11ViewersImpl: CEDAR MONITOR
IMPORTS Atom, Buttons, Commander, CommanderOps, ForkOps, Identification, ImagerColor, ImagerSample, InputFocus, IO, MessageWindow, Process, Rope, RuntimeError, SystemNames, SystemVersion, ViewerEvents, ViewerHelpStrings, ViewerOps, ViewersWorld, ViewersWorldClasses, ViewersWorldInitializations, X11Viewers, Xl, XlBitmap, XlDB, XlShmPixmaps, XlTQPrivate, XTk, XTkBitmapWidgets, XTkNotification, XTkPopUps, XTkTIPSource, XTkShellWidgets
EXPORTS X11Viewers, X11ViewersInstance, X11ViewersAccess =
BEGIN OPEN X11Viewers;
debugging: PUBLIC BOOL ¬ FALSE;
Use the interpreter to set a value
SetDebuggingTrue: PROC [] = {debugging ¬ TRUE};
SetDebuggingFalse: PROC [] = {debugging ¬ FALSE};
greeting: Rope.ROPE ~ "March 12, 1993";
Widget: TYPE = XTk.Widget;
initWidth: INT = 500;
initHeight: INT = 300;
minWidth: INT = 260;
minHeight: INT = 130;
------------------------
ImagerX11Preference: TYPE = {always, never, ifNoSharedMemory};
ImagerX11CreateProc: TYPE = PROC [connection: Xl.Connection, drawable: Xl.Drawable, pixelUnits: BOOL ¬ FALSE] RETURNS [Imager.Context];
imagerX11Create: ImagerX11CreateProc ¬ NIL;
useImagerX11: ImagerX11Preference ¬ ifNoSharedMemory; --under the presumption it is available...
AccessImagerX11IfLoaded: PROC [] = {
WITH Atom.GetProp[$ImagerX11, $ImagerX11CreateProc] SELECT FROM
rcp: REF ImagerX11CreateProc => IF rcp­#NIL THEN imagerX11Create ¬ rcp­
ENDCASE => {}
};
ImagerX11Command: Commander.CommandProc = {
--ImagerX11 is optional. It is wonderful for certain uses, but not recomended for other usage. Furthermore, on new releases ImagerX11 has been ported late and we can not depend on it.
Status: PROC [out: IO.STREAM] = {
data: ScreenServerData ¬ currentScreenServerData;
new: Rope.ROPE;
AccessImagerX11IfLoaded[];
SELECT useImagerX11 FROM
always => {
IF imagerX11Create=NIL
THEN new ¬ "would be used if it were loaded (it isn't)"
ELSE new ¬ "will be used"
};
never => new ¬ "will not be used";
ifNoSharedMemory => {
IF imagerX11Create=NIL
THEN new ¬ "would be used if it were loaded (it isn't) and shared memory is not feasible"
ELSE new ¬ "will be used if shared memory is not feasible"
};
ENDCASE => {};
IO.PutF1[out, "ImagerX11 (for new connections): %g\n", IO.rope[new]];
IF data#NIL THEN {
IF data.useBitmap
THEN {
WITH XTk.GetWidgetProp[data.bitmap, $XTkBitmapWidgetsImpl] SELECT FROM
r: Rope.ROPE => {
IO.PutRope[out, Rope.Cat["ImagerX11 is currently not used. Bitmap widgets say: ", r, "\n"]];
};
ENDCASE => {
IO.PutRope[out, "ImagerX11 is currently not used\n"];
};
}
ELSE IO.PutRope[out, "ImagerX11 is currently used\n"];
};
};
arg: Rope.ROPE ¬ CommanderOps.NextArgument[cmd];
AccessImagerX11IfLoaded[];
SELECT TRUE FROM
Rope.Equal[arg, "on", FALSE] => useImagerX11 ¬ always;
Rope.Equal[arg, "off", FALSE] => useImagerX11 ¬ never;
Rope.Equal[arg, "cond", FALSE] => useImagerX11 ¬ ifNoSharedMemory;
Rope.Equal[arg, "status", FALSE] => Status[cmd.out];
Rope.Equal[arg, "load", FALSE] => {
result ¬ CommanderOps.DoCommand["require Cedar ImagerX11 ImagerX11", cmd];
};
ENDCASE => {
CommanderOps.Failed["Use one argument: {status|on|off|cond|load}"];
};
};
------------------------
focusModeActive: BOOL ¬ FALSE; -- ICCCM input focus mode:
-- TRUE => Globally active;
-- FALSE => Passive
init: BOOL ¬ FALSE; --so initialization is done just once
currentScreenServerData: ScreenServerData ¬ NIL;
--Global data used to restart on failures
globalLastData: ScreenServerData ¬ NIL;
globalStartServerName: Rope.ROPE ¬ NIL;
baseClass: PUBLIC ViewersWorldClasses.ViewersWorldClass ¬
NEW[ViewersWorldClasses.ViewersWorldClassObj ¬ [
creator: CreateContext
]];
errorMatch: Xl.Match ¬ NEW[Xl.MatchRep ¬ [tq: Xl.CreateTQ[]]]; --this match allows to collect all X errors on a single thread; it helps to reduce number of threads blocked on X errors
bitsPerPixelOk: PUBLIC ERROR ~ CODE;
CloseConnectionFromWidget: PROC [w: XTk.Widget] = {
IF w#NIL THEN {
c: Xl.Connection ~ w.connection;
WITH XTk.GetWidgetProp[w, $X11ViewersData] SELECT FROM
data: ScreenServerData => IF data.top=w THEN {
Warning[data];
Process.PauseMsec[50];
};
ENDCASE => {};
IF w.connection=c THEN Xl.CloseConnection[c];
};
};
WMDeleteWindow: XTk.WidgetNotifyProc = {
data: ScreenServerData ¬ NARROW[XTk.GetWidgetProp[widget, $X11ViewersData]];
TRUSTED {Process.Detach[FORK XTkPopUps.SimplePopUpWithRegularShell[
screen: widget.screenDepth.screen,
header: Rope.Cat["Quit [", Identification.Self[], "]"],
list: quitList,
defaultNotify: TopMenuNotify,
registerData: data
]]};
};
ProblemNotifier: XTk.WidgetNotifyProc = {
failed: BOOL ¬ FALSE;
c: Xl.Connection;
XTkShellWidgets.ForgetScreenShell[widget];
c ¬ Xl.CreateConnection[server: globalStartServerName, applicationKey: $CedarViewers, debugHelp: $CedarViewers, errorMatch: errorMatch ! UNCAUGHT => {failed ¬ TRUE; CONTINUE}];
IF ~failed THEN
XTkShellWidgets.BindScreenShell[widget, c ! UNCAUGHT => {failed ¬ TRUE; CONTINUE}];
IF ~failed THEN
XTkShellWidgets.RealizeShell[widget ! UNCAUGHT => {failed ¬ TRUE; CONTINUE}];
IF failed THEN {
XTkShellWidgets.DestroyShell[widget] --rely on the periodic awakener to start it again
};
Xl.DecRefCount[c];
};
ColoredCaptions: PROC [on: BOOL] = {
IF on
THEN {
captionBackgroundColor: Imager.Color ¬ ImagerColor.ColorFromRGB[[R: 0.7, G: 0.7, B: 1.0]];
captionDropshadowColor: Imager.Color ¬ captionBackgroundColor;
captionSidebarColor: Imager.Color ¬ captionBackgroundColor;
captionForegroundColor: Imager.Color ¬ ImagerColor.ColorFromRGB[[R: 0.0, G: 0.0, B: 1.0]];
Atom.PutProp[$ViewerCaptionColors, $foreground, captionForegroundColor];
Atom.PutProp[$ViewerCaptionColors, $dropshadow, captionDropshadowColor];
Atom.PutProp[$ViewerCaptionColors, $background, captionBackgroundColor];
Atom.PutProp[$ViewerCaptionColors, $sidebar, captionSidebarColor];
}
ELSE {
Atom.PutProp[$ViewerCaptionColors, $foreground, NIL];
Atom.PutProp[$ViewerCaptionColors, $dropshadow, NIL];
Atom.PutProp[$ViewerCaptionColors, $background, NIL];
Atom.PutProp[$ViewerCaptionColors, $sidebar, NIL];
};
};
CurrentServer: PUBLIC PROC [] RETURNS [Rope.ROPE] = {
c: Xl.Connection ~ CurrentConnection[];
IF Xl.Alive[c] THEN RETURN [Xl.ServerName[c]];
RETURN [globalStartServerName]
};
CurrentConnection: PUBLIC PROC [] RETURNS [Xl.Connection ¬ NIL] = {
data: ScreenServerData ¬ currentScreenServerData;
IF data#NIL THEN RETURN [data.top.connection]
};
Shell: PUBLIC PROC [] RETURNS [XTk.Widget ¬ NIL] = {
data: ScreenServerData ¬ currentScreenServerData;
IF data#NIL THEN RETURN [data.top]
};
wasMigrating: REF ¬ NIL;
PeriodicalCheckLiveness: PROC [unused: REF ¬ NIL] = {
ENABLE {
Xl.XError => {
IF ~debugging THEN GOTO oops
};
RuntimeError.UNCAUGHT => {
IF ~debugging THEN GOTO oops
};
};
data: ScreenServerData ¬ globalLastData;
IF data#NIL THEN {
w: XTk.Widget ~ data.top;
migrating: REF ~ XTk.GetWidgetProp[w, $Migrating];
IF migrating#NIL AND wasMigrating#migrating THEN {
wasMigrating ¬ migrating; RETURN
};
wasMigrating ¬ NIL;
IF w#NIL THEN
IF w.fastAccessAllowed#ok OR ~Xl.Alive[w.connection] THEN {
Revive[data, globalStartServerName]
}
};
EXITS oops => {}
};
InstNameForWidget: PROC [] RETURNS [instName: ATOM] = {
instName ¬ Atom.MakeAtom[Rope.Concat["CedarViewers-", SystemNames.MachineName[]]];
};
Start: PUBLIC PROC [server: Rope.ROPE ¬ NIL] = {
vWorld: ViewersWorld.Ref;
data: ScreenServerData ~ NEW[ScreenServerDataRec];
copiedClass: ViewersWorldClasses.ViewersWorldClass ¬ NEW[ViewersWorldClasses.ViewersWorldClassObj ¬ baseClass­];
copiedClass.properties ¬ NIL;
IF server=NIL THEN server ¬ globalStartServerName;
vWorld ¬ ViewersWorldClasses.CreateViewersWorld[copiedClass, NIL, data];
data.screens[main] ¬ data;
data.class ¬ copiedClass;
data.viewersWorld ¬ vWorld;
data.width ¬ initWidth;
data.height ¬ initHeight;
ViewersWorld.SetSize[vWorld, initWidth, initHeight, NIL];
ViewersWorldInitializations.StartInstallation[vWorld];
[] ¬ Buttons.Create[
info: [name: "X11Viewers"], proc: XViewersButtonClick, fork: TRUE,
documentation: "X11 Viewers options",
clientData: data
];
MessageWindow.Append[greeting, TRUE];
ViewersWorldInitializations.FinishInstallation[vWorld];
globalStartServerName ¬ server;
Revive[data, server];
IF ~init THEN {
ForkOps.ForkPeriodically[ms: 5000, proc: PeriodicalCheckLiveness];
init ¬ TRUE;
};
};
RegisterSynchronizer: XTk.WidgetNotifyProc = {
XTk.SynchronizeFastAccess[widget, Xl.NarrowTQ[registerData]];
};
CallPreWindowCreators: XTk.WidgetNotifyProc = {
okRaised: BOOL ¬ FALSE;
data: ScreenServerData ~ NARROW[registerData];
IF data.useBitmap
THEN {
data.possibleBitsPerPixel ¬ 8;
XTkNotification.CallAll[X11Viewers.checkBitsPerPixel, data.top, data ! bitsPerPixelOk => {okRaised ¬ TRUE; CONTINUE}];
IF ~okRaised THEN {
data.possibleBitsPerPixel ¬ 4;
XTkNotification.CallAll[X11Viewers.checkBitsPerPixel, data.top, data ! bitsPerPixelOk => {okRaised ¬ TRUE; CONTINUE}];
};
IF ~okRaised THEN {
data.possibleBitsPerPixel ¬ 2;
XTkNotification.CallAll[X11Viewers.checkBitsPerPixel, data.top, data ! bitsPerPixelOk => {okRaised ¬ TRUE; CONTINUE}];
};
IF ~okRaised THEN data.possibleBitsPerPixel ¬ 1;
data.bitmap.attributes.backingStore ¬ notUseful;
}
ELSE {
data.possibleBitsPerPixel ¬ 1;
data.bitmap.attributes.backingStore ¬ whenMapped;
};
XTkNotification.CallAll[X11Viewers.beforeWindowCreation, data.top, data];
};
Revive: ENTRY PROC [data: ScreenServerData, server: Rope.ROPE ¬ NIL] = {
ENABLE UNWIND => NULL;
connection: Xl.Connection;
uioHandle: UserInput.Handle;
geometry: Xl.Geometry ¬ [];
old: XTk.Widget;
inputTQ: Xl.TQ ¬ Xl.CreateTQ[];
Warning[data];
XlTQPrivate.SetTQPriority[inputTQ, Process.priorityClient3];
XlTQPrivate.SetTQReadiness[inputTQ, 60000]; --1 minute
connection ¬ Xl.CreateConnection[server: server, applicationKey: $CedarViewers, debugHelp: $CedarViewers, errorMatch: errorMatch];
old ¬ data.top;
data.top ¬ XTkShellWidgets.CreateShell[
widgetSpec: [geometry: geometry, instName: InstNameForWidget[]],
className: $CedarViewers,
packageName: "X11Viewers",
shortName: "X11Viewers",
windowHeader: IO.PutFLR["Cedar%g.%g.%g from %g",
LIST[[integer[SystemVersion.release.major]], [integer[SystemVersion.release.minor]], [integer[SystemVersion.release.patch]], [rope[Identification.Self[]]] ] ],
iconName: Identification.Self[],
standardMigration: TRUE
];
XTk.RegisterNotifier[data.top, XTk.bindScreenLRKey, BindScreenNotified, data];
XTk.RegisterNotifier[data.top, XTk.preWindowCreationKey, RegisterSynchronizer, inputTQ];
XTk.PutWidgetProp[data.top, $X11ViewersData, data];
XTkShellWidgets.RegisterCallWMDeleteWindow[data.top, WMDeleteWindow];
XTkShellWidgets.RegisterCallConnectionDied[data.top, ProblemNotifier];
XTkShellWidgets.RegisterCallWindowDied[data.top, ProblemNotifier];
data.bitmap ¬ XTkBitmapWidgets.CreateBitmapWidget[notify: ResizeNotify];
XTkShellWidgets.SetShellChild[data.top, data.bitmap];
XTk.RegisterNotifier[data.bitmap, XTk.preWindowCreationKey, CallPreWindowCreators, data];
XTk.AddPermanentMatch[data.top, [proc: XLostFocus, handles: Xl.CreateEventFilter[focusOut], tq: inputTQ, data: data], [focusChange: TRUE]];
data.tsh ¬ XTkTIPSource.BindTipSource[widget: data.bitmap, yup: TRUE, inputTQ: inputTQ, setAbsoluteTime: TRUE];
XTkTIPSource.AdditionalKeySource[data.tsh, data.top];
uioHandle ¬ ViewersWorld.GetInputHandle[data.viewersWorld];
XTkTIPSource.ReplaceUIOHandle[data.tsh, uioHandle, TRUE];
SetInputFocusMethod[data.top, ClickToTypeFromDB[connection]];
XTkNotification.CallAll[X11Viewers.afterWidgetCreation, data.top, data];
currentScreenServerData ¬ data;
XTkShellWidgets.BindScreenShell[data.top, connection];
XTkShellWidgets.RealizeShell[data.top];
Reset[data];
Xl.DecRefCount[connection];
IF Xl.Alive[connection] THEN {
globalLastData ¬ data;
};
IF old#NIL AND old.state<existing THEN {
Process.PauseMsec[400];
XTkShellWidgets.DestroyShell[old ! RuntimeError.UNCAUGHT => IF ~debugging THEN CONTINUE];
};
};
BindScreenNotified: XTk.WidgetNotifyProc = {
data: ScreenServerData ~ NARROW[registerData];
--It makes sense to check the size, since there are two frequent problems
-- Many CSL people have personal defaults which exceed liveboard screen size.
-- Many non CSL people have defaults so small that they cause problems to viewers.
width, height: INT;
screen: Xl.Screen ¬ widget.screenDepth.screen;
width ¬ data.top.s.geometry.size.width;
IF width>screen.sizeInPixels.width OR width<minWidth THEN
width ¬ data.top.s.geometry.size.width ¬ screen.sizeInPixels.width-100;
height ¬ data.top.s.geometry.size.height;
IF height>screen.sizeInPixels.height OR height<minHeight THEN
height ¬ data.top.s.geometry.size.height ¬ screen.sizeInPixels.height-100;
data.top.s.geometry.size.width ¬ (width/4) * 4; -- round to multiple of 4 for icon pattern alignments
data.top.s.geometry.size.height ¬ (height/4) * 4;
AccessImagerX11IfLoaded[];
SELECT useImagerX11 FROM
always => {data.useBitmap ¬ imagerX11Create=NIL};
ifNoSharedMemory => {data.useBitmap ¬ imagerX11Create=NIL OR XlShmPixmaps.ConnectionSupportsThis[widget.connection]};
ENDCASE => {data.useBitmap ¬ TRUE};
IF ~data.useBitmap THEN {
data.actualBitsPerPixel ¬ 1;
data.actualSurfaceUnitsPerPixel ¬ 1;
XTk.AddTemporaryMatch[data.bitmap, [proc: PaintOnExpose, handles: Xl.CreateEventFilter[expose], tq: Xl.CreateTQ[], data: data], [exposure: TRUE]];
XTk.AddTemporaryMatch[data.bitmap, [proc: ResizeEvent, handles: Xl.CreateEventFilter[configureNotify], tq: data.top.rootTQ, data: data], [structureNotify: TRUE]];
XTkBitmapWidgets.SetBitmap[widget: data.bitmap, bitmap: NIL, immediateRefresh: FALSE, retainRefreshs: FALSE]
}
};
PaintOnExpose: Xl.EventProcType = {
--Necessary for the ImagerX11 implementation
WITH event SELECT FROM
expose: Xl.ExposeEvent => IF expose.count<=0 THEN ViewerOps.PaintEverything[];
ENDCASE => {};
};
ResizeEvent: Xl.EventProcType = {
--Necessary for the ImagerX11 implementation
data: ScreenServerData ~ NARROW[clientData];
WITH event SELECT FROM
configureNotify: Xl.ConfigureNotifyEvent => {
data.width ¬ MAX[configureNotify.geometry.size.width, minWidth];
data.height ¬ MAX[configureNotify.geometry.size.height, minHeight];
ViewersWorld.SetSize[data.viewersWorld, data.width, data.height]; --also calls ViewerOps.PaintEverything
Reset[data];
Xl.Flush[data.top.connection];
};
ENDCASE => {};
};
ClickToTypeFromDB: PROC [c: Xl.Connection] RETURNS [clickToType: BOOL ¬ FALSE] = {
--returns whether Cedar preferes a clickToType model or not
clickToType ¬ DBMatches[c, "(Cedar|cedar)(InputFocusMode)", "*click*", FALSE];
};
DBMatches: PROC [c: Xl.Connection, query: Rope.ROPE, matchPattern: Rope.ROPE ¬ NIL, resultIfNIL: BOOL ¬ FALSE, case: BOOL ¬ FALSE] RETURNS [b: BOOL ¬ FALSE] = {
answer: Rope.ROPE ¬ XlDB.QueryStandardDB[c, query];
IF answer=NIL THEN RETURN [resultIfNIL];
IF matchPattern=NIL THEN matchPattern ¬ "*true*";
b ¬ Rope.Match[pattern: matchPattern, object: answer, case: case];
};
ChangeDisplayMode: PROC [a: ATOM, init: BOOL ¬ FALSE, alwaysSetSize: BOOL ¬ FALSE] = {
trustMeNoSizeChange: BOOL ¬ FALSE;
data: ScreenServerData ¬ currentScreenServerData;
IF data#NIL THEN {
top: XTk.Widget ¬ data.top;
IF top#NIL THEN {
IF a=$initial THEN a ¬ InitialDisplayMode[top.connection];
SELECT a FROM
$color8 => {
IF top.screenDepth#NIL AND top.screenDepth.depth=8 AND data.possibleBitsPerPixel>=8
THEN data.preparedBitsPerPixel ¬ 8
ELSE data.preparedBitsPerPixel ¬ 1;
};
$color4 => {
IF top.screenDepth#NIL AND top.screenDepth.depth=4 AND data.possibleBitsPerPixel=4
THEN data.preparedBitsPerPixel ¬ 4
ELSE data.preparedBitsPerPixel ¬ 1;
};
$bw => {
data.preparedBitsPerPixel ¬ 1;
data.preparedSurfaceUnitsPerPixel ¬ 1;
};
$bwX2 => {
data.preparedBitsPerPixel ¬ 1;
data.preparedSurfaceUnitsPerPixel ¬ 2;
};
ENDCASE => RETURN;
IF data.preparedBitsPerPixel>1 THEN {
data.preparedSurfaceUnitsPerPixel ¬ 1; --prevent impossible combination
};
IF data.preparedBitsPerPixel<1 THEN data.preparedBitsPerPixel ¬ 1;
IF data.preparedSurfaceUnitsPerPixel#2 THEN data.preparedSurfaceUnitsPerPixel ¬ 1;
IF data.preparedBitsPerPixel=data.actualBitsPerPixel THEN trustMeNoSizeChange ¬ TRUE;
IF alwaysSetSize OR data.preparedBitsPerPixel#data.actualBitsPerPixel OR data.preparedSurfaceUnitsPerPixel#data.actualSurfaceUnitsPerPixel THEN
MySetSize[data: data, init: init, trustMeNoSizeChange: trustMeNoSizeChange];
};
}
};
DBDisplayMode: PUBLIC PROC [c: Xl.Connection] RETURNS [ATOM¬NIL] = {
query, answer: Rope.ROPE;
bwOnly: BOOL ¬ FALSE;
IF ~Xl.Alive[c] THEN RETURN [NIL];
IF XlShmPixmaps.ConnectionSupportsThis[c]
THEN query ¬ "(Cedar)(shared)(BWOnlyMode)"
ELSE query ¬ "(Cedar)(remote)(BWOnlyMode)";
answer ¬ XlDB.QueryStandardDB[c, query];
IF Rope.Match[pattern: "*true*", object: answer, case: FALSE] THEN RETURN [$bw];
IF Rope.Match[pattern: "*false*", object: answer, case: FALSE] THEN RETURN [$color8];
};
BareDisplayMode: PUBLIC PROC [c: Xl.Connection] RETURNS [ATOM] = {
IF ~Xl.Alive[c] THEN RETURN [$bw];
IF ~XlShmPixmaps.ConnectionSupportsThis[c] THEN RETURN [$bw];
RETURN [$color8];
};
InitialDisplayMode: PROC [c: Xl.Connection] RETURNS [a: ATOM] = {
a ¬ globalDisplayMode;
IF a=NIL OR a=$db THEN a ¬ DBDisplayMode[c];
SELECT a FROM
$bw, $bwX2, $color8, $color4 => RETURN [a];
ENDCASE => RETURN [BareDisplayMode[c]];
};
ActualDisplayMode: PUBLIC PROC [] RETURNS [ATOM] = {
data: ScreenServerData ¬ currentScreenServerData;
c: Xl.Connection;
IF data=NIL THEN RETURN [NIL];
c ¬ data.top.connection;
IF ~Xl.Alive[c] THEN RETURN [NIL];
IF ~data.useBitmap THEN RETURN [$imagerx11];
IF data.actualBitsPerPixel=8 THEN RETURN [$color8];
IF data.actualBitsPerPixel=4 THEN RETURN [$color4];
IF data.actualBitsPerPixel=2 THEN RETURN [$color2];
IF data.actualSurfaceUnitsPerPixel#1 THEN RETURN [$bwX2];
RETURN [$bw];
};
globalDisplayMode: ATOM ¬ NIL;
SetDefaultDisplayMode: PUBLIC PROC [a: ATOM ¬ NIL] = {
globalDisplayMode ¬ a
};
SetDisplayMode: PUBLIC PROC [a: ATOM ¬ NIL] = {
data: ScreenServerData ¬ currentScreenServerData;
c: Xl.Connection;
IF data=NIL THEN RETURN;
c ¬ data.top.connection;
IF ~Xl.Alive[c] THEN RETURN;
IF a=NIL THEN {
SELECT globalDisplayMode FROM
$bw, $bwX2, $color8, $color4 => a ¬ globalDisplayMode;
ENDCASE => a ¬ DBDisplayMode[c];
};
IF a=$db THEN a ¬ DBDisplayMode[c];
IF a=$default OR a=NIL OR a=$bare THEN a ¬ BareDisplayMode[c];
SELECT a FROM
$bw, $bwX2, $color8, $color4, $initial => ChangeDisplayMode[a];
ENDCASE => {};
};
LoseCedarFocus: PROC [shell: XTk.Widget] = {
IF shell.fastAccessAllowed=ok THEN Xl.SetInputFocus[c: shell.connection, timeStamp: Xl.currentTime];
InputFocus.SetInputFocus[]; --loose Cedar focus so when it is set again it will propagate to X
};
ForceFocus: PROC [shell: XTk.Widget] = {
IF shell.fastAccessAllowed=ok THEN
XTkShellWidgets.SetFocus[shell, Xl.currentTime];
};
SetInputFocusMethod: PROC [shell: XTk.Widget, clickToType: BOOL] = {
XTkShellWidgets.WithDraw[shell];
IF clickToType
THEN{
--use ICCCM Globally active input; must set X input focus as consequence of Cedar viewer event
XTkShellWidgets.SetFocusMethod[shell: shell, focusProtocol: true, inputHint: false];
focusModeActive ¬ TRUE;
InputFocus.SetInputFocus[]; --loose Cedar focus so when it is set again it will propagate to X
}
ELSE {
--real estate mode
--use ICCCM passive input; no need to fool around with X input focus
focusModeActive ¬ FALSE;
XTkShellWidgets.SetFocusMethod[shell: shell, focusProtocol: false, inputHint: true];
IF shell.fastAccessAllowed=ok THEN
Xl.SetInputFocus[shell.connection, Xl.focusPointerRoot, parent, XTkShellWidgets.FocusTime[shell]]; --Give X focus back. Not legal according to ICCCM, but very necessary if there is no X window manager...
};
IF shell.actualMapping<unconfigured AND shell.fastAccessAllowed=ok THEN Xl.MapWindow[shell.connection, shell.window];
};
XViewersButtonClick: ViewerClasses.ClickProc = {
data: ScreenServerData ¬ NARROW[clientData];
screen: Xl.Screen ¬ data.top.screenDepth.screen;
TRUSTED {Process.Detach[FORK XTkPopUps.SimplePopUpWithRegularShell[
screen: screen,
header: Rope.Cat["Options [", Identification.Self[], "]"],
list: topMenuList,
defaultNotify: TopMenuNotify,
registerData: data,
helpHandle: ViewerHelpStrings.GetHandle[]
]]};
};
TopMenuNotify: XTk.WidgetNotifyProc = {
--Called to execute random pop up menu commands
data: ScreenServerData ¬ NARROW[registerData];
SELECT callData FROM
$allup => XTkTIPSource.AllUp[data.bitmap];
$focusR => SetInputFocusMethod[data.top, FALSE];
$focusC => SetInputFocusMethod[data.top, TRUE];
$looseCedarFocus => LoseCedarFocus[data.top];
$forceFocus => ForceFocus[data.top];
$colorDB => SetDisplayMode[DBDisplayMode[CurrentConnection[]]];
$bwX2 => SetDisplayMode[$bwX2];
$bw => SetDisplayMode[$bw];
$color8 => SetDisplayMode[$color8];
$color4 => SetDisplayMode[$color4];
$DestroyConnection => CloseConnectionFromWidget[data.top];
$Withdraw => XTkShellWidgets.WithDraw[data.top];
$repaint => ViewerOps.PaintEverything[];
$save => ViewerOps.SaveAllEdits[];
$restartInput => ViewersWorld.RestartInput[data.viewersWorld];
ENDCASE => {}
};
TopMenuCmd: XTk.WidgetNotifyProc = {
--Called to execute pop up menu commands by executing command line
command: Rope.ROPE;
WITH callData SELECT FROM
r: Rope.ROPE => command ¬ r;
r: REF TEXT => command ¬ Rope.FromRefText[r];
ENDCASE => RETURN;
[] ¬ CommanderOps.DoCommand[Rope.Concat[command, "\n"], NIL];
};
TopMenuX11: XTk.WidgetNotifyProc = {
--Called to execute pop up menu commands by executing command line using same X server
commandLine, command: Rope.ROPE;
WITH callData SELECT FROM
r: Rope.ROPE => command ¬ r;
r: REF TEXT => command ¬ Rope.FromRefText[r];
ENDCASE => RETURN;
commandLine ¬ IO.PutFR["X11 -display %g -- %g\n", IO.rope[CurrentServer[]], IO.rope[command]];
[] ¬ CommanderOps.DoCommand[commandLine, NIL];
};
Tx: PROC [text, command, help: REF TEXT] RETURNS [XTkPopUps.Choice] = {
--Menu choice: executing command with same X server
RETURN [[text, command, NIL, help, TopMenuX11]];
};
Tc: PROC [text, command, help: REF TEXT] RETURNS [XTkPopUps.Choice] = {
--Menu choice: executing command
RETURN [[text, command, NIL, help, TopMenuCmd]];
};
Tm: PROC [text: REF TEXT, menu: XTkPopUps.ChoiceList] RETURNS [XTkPopUps.Choice] = {
--Menu choice: select a sub-menu
RETURN [[text, NIL, menu, "Shows another menu"]];
};
inputFocusList: XTkPopUps.ChoiceList ¬ LIST[
["take X focus", $forceFocus],
["give up Cedar and X focus", $looseCedarFocus],
["support real estate", $focusR],
["support click to type", $focusC]
];
surfaceUnitsList: XTkPopUps.ChoiceList ¬ LIST[
[" 1 ", $su1],
[" 2 if possible", $su2]
];
displayModeList: XTkPopUps.ChoiceList ¬ LIST[
["default", $colorDB],
["BW", $bw],
["color 8 (if hw supported)", $color8],
["color 4 (only if 4 bpp is but 8 bpp isn't supported)", $color4],
["BW x2", $bwX2]
];
applicationsList: XTkPopUps.ChoiceList ¬ LIST[
Tx["Migration tool", "X11MigrationTool", "Create migration tool widget"],
Tx["Screen spy", "ScreenSpy", "Create a screen spy widget"],
Tx["Commander", "XCommander", "Create a commander widget"],
Tx["Feedback tool", "XTkFeedbackCreate", "Create a feedback control widget"],
Tx["Clipboard tool", "X11ClipHack", "Create a clipboard widget"],
Tx["XNS credentials tool", "XCredentialTool", "Accept XNS credentials"],
Tx["Terminal by X11", "TerminalByX11", "For acception remote viewers"]
];
imagerX11List: XTkPopUps.ChoiceList ¬ LIST[
Tc["always", "ImagerX11 load; ImagerX11 on", "Use ImagerX11 for future connections"],
Tc["never", "ImagerX11 off", "Don't use ImagerX11 for future connections"],
Tc["conditional", "ImagerX11 cond; ImagerX11 load", "Use ImagerX11 for future connections if shm not available"]
];
rescuesList: XTkPopUps.ChoiceList ¬ LIST[
["Save edits", $save],
["Try restarting input", $restartInput],
["Assert all keys up", $allup],
["Repaint", $repaint],
["Destroy connection", $DestroyConnection]
];
topMenuList: XTkPopUps.ChoiceList ¬ LIST[
Tc["Exit Cedar", "ExitWorld", "Terminates all activities immediately (kill process)"],
["Withdraw window", $Withdraw],
Tm["Rescues...", rescuesList],
Tm["Display mode...", displayModeList],
Tm["Imager-X11...", imagerX11List],
Tm["Input focus...", inputFocusList],
Tm["Applications...", applicationsList],
["Dismiss", $Dismiss, NIL, "get rid of menu", DismissNotify]
];
quitList: XTkPopUps.ChoiceList ¬ LIST[
Tc["Exit Cedar", "ExitWorld", "Terminates all activities immediately (kill process)"],
["Withdraw window", $Withdraw],
Tm["X11Viewers main menu...", topMenuList],
["Dismiss", $Dismiss, NIL, "get rid of menu", DismissNotify]
];
DismissNotify: XTk.WidgetNotifyProc = {
XTkShellWidgets.DestroyShell[XTk.RootWidget[widget]];
};
MySetSize: PROC [data: ScreenServerData, init: BOOL ¬ FALSE, trustMeNoSizeChange: BOOL ¬ FALSE] = {
bppChange: BOOL ¬ FALSE;
oldBM: XlBitmap.Bitmap ¬ data.bm;
widget: XTk.Widget ¬ data.bitmap;
bitsPerPixel: NAT ¬ data.preparedBitsPerPixel;
surfaceUnitsPP: NAT ¬ IF bitsPerPixel#1 THEN 1 ELSE data.preparedSurfaceUnitsPerPixel;
neww: NAT ¬ MAX[widget.actual.size.width/surfaceUnitsPP, minWidth];
newh: NAT ¬ MAX[widget.actual.size.height/surfaceUnitsPP, minWidth];
IF oldBM=NIL
THEN init ¬ TRUE
ELSE {
oldsm: Imager.SampleMap ¬ XlBitmap.GetSM[oldBM];
oldbpp: NAT ¬ ImagerSample.GetBitsPerSample[oldsm];
IF oldbpp#bitsPerPixel THEN bppChange ¬ TRUE
};
IF ~trustMeNoSizeChange OR bppChange OR init THEN {
w: NAT ¬ neww*surfaceUnitsPP;
h: NAT ¬ newh*surfaceUnitsPP;
bm: XlBitmap.Bitmap ¬ NIL;
IF data.useBitmap THEN
bm ¬ XlBitmap.Create[size: [s: h, f: w], bpp: bitsPerPixel];
data.bm ¬ bm;
data.actualBitsPerPixel ¬ bitsPerPixel;
XTkNotification.CallAll[X11Viewers.bitmapReplaced, widget, data];
XTkBitmapWidgets.SetBitmap[widget: widget, bitmap: bm, immediateRefresh: FALSE];
ColoredCaptions[bitsPerPixel>1];
};
data.actualSurfaceUnitsPerPixel ¬ surfaceUnitsPP;
XTkTIPSource.ChangeSurfaceUnitsPerPixel[data.tsh, surfaceUnitsPP];
data.width ¬ neww; data.height ¬ newh;
ViewersWorld.SetSize[data.viewersWorld, neww, newh]; --as side effect calls ViewerOps.PaintEverything
Reset[data];
};
ResizeNotify: XTkBitmapWidgets.BitmapEventProc = {
IF reason IN [createWindow..resize] THEN {
WITH XTk.GetWidgetProp[XTk.RootWidget[widget], $X11ViewersData] SELECT FROM
data: ScreenServerData => {
IF reason=createWindow
THEN ChangeDisplayMode[$initial, TRUE, TRUE]
ELSE MySetSize[data: data, init: FALSE];
};
ENDCASE => {};
};
};
noWhereBM: XlBitmap.Bitmap ~ XlBitmap.Create[[1, 1], 1, FALSE];
NoWhereContext: PROC [] RETURNS [Imager.Context] = {
RETURN [XlBitmap.CreateContext[noWhereBM, 1]];
};
CreateContext: ViewerScreenTypes.ContextCreatorProc = {
--Creates context. But: returned context is not visible
-- if procedure used before window is realized
-- or after window is resized
--This class procedure will be overwritten when the color implementation is loaded
WITH screenServerData SELECT FROM
data: ScreenServerData => {
IF data.useBitmap
THEN {
w: XTk.Widget = data.bitmap;
IF w#NIL AND w.fastAccessAllowed=ok THEN {
RETURN [XTkBitmapWidgets.CreateContext[w, data.actualSurfaceUnitsPerPixel]]
};
}
ELSE {
w: XTk.Widget ~ data.bitmap;
create: ImagerX11CreateProc ¬ imagerX11Create;
IF w#NIL AND w.fastAccessAllowed=ok AND create#NIL THEN {
RETURN [create[w.connection, w.window, TRUE]]
};
};
};
ENDCASE => {};
RETURN [NoWhereContext[]];
};
CedareDidSetInputFocus: ViewerEvents.EventProc = {
data: ScreenServerData ~ currentScreenServerData;
IF focusModeActive AND data#NIL THEN {
time: Xl.TimeStamp ~ Xl.currentTime; --illegal according to ICCCM, but it is nevertheless much more reliable. ChJ.
IF viewer#NIL
THEN {
--Make sure the X Window focus is set to the Cedar base window
XTkShellWidgets.SetFocus[data.top, time, data.bitmap]; --does not raise X errors
}
ELSE {
--Make sure we won't accept focus client messages
XTkShellWidgets.SetFocusTarget[data.top, NIL, time] --does not raise X errors
}
};
};
XLostFocus: Xl.EventProcType = {
--The Cedar base window lost the X window input focus. Make sure Cedar will not think it still has the input focus. Because, if it would so, it would optimize away a later call to put the input focus to the same Cedar viewer, and, we would not know when to claim the X window input focus back.
IF focusModeActive AND clientData=currentScreenServerData THEN
WITH event SELECT FROM
focusOut: Xl.FocusOutEvent => {
SELECT focusOut.detail FROM
ancestor, virtual, nonlinear, nonlinearVirtual => InputFocus.SetInputFocus[]
inferior => RETURN; --lost focus towards bitmap; thats ok
Pointer, PointerRoot, None => RETURN;
ENDCASE => {};
};
ENDCASE => {};
};
KillConnectionCommand: Commander.CommandProc = {
data: ScreenServerData ¬ currentScreenServerData;
IF data#NIL THEN CloseConnectionFromWidget[data.top]
};
DebugCommand: Commander.CommandProc = {
data: ScreenServerData ¬ currentScreenServerData;
IF data#NIL THEN {
--Put in here whatever I want to debug...
Reset[data];
}
};
HostCommand: Commander.CommandProc = {
IO.PutF1[cmd.out, "%g\n", [rope[Identification.Self[$Debug]]] ]
};
VersionCommand: Commander.CommandProc = {
IO.PutF1[cmd.out, " X11Viewers Version - %g\n", [rope[greeting]] ]
};
Last: PUBLIC PROC [] RETURNS [X11Viewers.ScreenServerData] = {
RETURN [currentScreenServerData];
};
Execute: PROC [r: Rope.ROPE] = {
commandLine: Rope.ROPE ~ IO.PutFR["X11 -display %g -- %g\n", IO.rope[CurrentServer[]], IO.rope[r]];
[] ¬ CommanderOps.DoCommand[commandLine, NIL];
};
DefaultServerCommand: Commander.CommandProc = {
num: INT ¬ CommanderOps.NumArgs[cmd];
SELECT num FROM
1 => {};
2 => {
serverName: Rope.ROPE ~ CommanderOps.NextArgument[cmd];
c: Xl.Connection ¬ Xl.CreateConnection[serverName
! Xl.connectionNotCreated => CommanderOps.Failed[why.reason];
];
Xl.CloseConnection[c];
globalStartServerName ¬ serverName 
};
ENDCASE => CommanderOps.Failed["Format is: X11ViewersDefaultServer {server}"];
msg ¬ IO.PutFR1["%g\n", IO.rope[globalStartServerName]];
};
Atom.PutProp[$Viewers, $Viewers, $X11Viewers];
[] ¬ ViewerEvents.RegisterEventProc[proc: CedareDidSetInputFocus, event: setInputFocus, before: FALSE];
--
--Commands
Commander.Register["X11ViewersKillConnection", KillConnectionCommand, "Destroys X window connection; hopefully a new connection will be arranged"];
Commander.Register["X11ViewersDebug", DebugCommand, "Christians debug hack"];
--
Commander.Register["X11ViewersImagerX11", ImagerX11Command, "Set parameters for ImagerX11 usage"];
Commander.Register["ImagerX11", ImagerX11Command, "Set parameters for ImagerX11 usage"];
--
Commander.Register["X11ViewersDefaultServer", DefaultServerCommand, "Set place for default server"];
--
--
Commander.Register["X11ViewersVersion", VersionCommand, "Prints greeting message"];
Commander.Register["Self", HostCommand, "Prints name of host"];
--
END.