<> <> <> <> <> <> <> <> <<>> 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; <> 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 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 widthscreen.sizeInPixels.height OR height {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> 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[] < RETURN; --lost focus towards bitmap; thats ok>> < 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.