<> <> <> <> DIRECTORY Ascii, Atom, Random, Rope, RopeList, Xl, XlICCCMTypes, XlConventions, XlDispatch, XlPredefinedAtoms, XTk, XTkDB, XTkIcon, XTkFriends, XTkMigration, XTkNotification, XTkPrivate, XTkShellWidgets; XTkShellWidgetsImpl: CEDAR MONITOR IMPORTS Atom, Random, Rope, RopeList, XlDispatch, Xl, XlConventions, XTk, XTkDB, XTkFriends, XTkIcon, XTkMigration, XTkNotification, XTkPrivate EXPORTS XTkShellWidgets SHARES Xl, XTk = BEGIN OPEN Xl, XTk, XTkShellWidgets; shellClass: ImplementorClass ¬ XTkFriends.CreateClass[[key: $top, wDataNum: 1, preferredSizeLR: ShellPreferredSizeLR, preStopFastAccess: ShellPreStopFastAccess, configureLR: ShellConfigureLR, initInstPart: ShellInitInstPart, className: ShellClassName, eventMask: [structureNotify: TRUE], backgroundKey: $white, removeChildLR: ShellRemoveChildLR, internalEnumerateChildren: ShellInternalEnumerateChildren, forgetScreenLR: ShellForgetScreenLR, bindScreenLX: ShellBindScreenLX]]; <<>> ToWindow: PROC [x: REF READONLY ANY] RETURNS [w: Xl.Window ¬ Xl.nullWindow] = { WITH x SELECT FROM widget: REF READONLY WidgetRep => w ¬ widget.window; window: REF READONLY Window => w ¬ window­; ENDCASE => {}; }; IsShell: PUBLIC PROC [w: XTk.Widget] RETURNS [BOOL] = { RETURN [XTk.HasClass[w, shellClass]]; }; connectionDeadSet: EventFilter ~ Xl.CreateEventFilter[finalEvent]; ConnectionDiedHandler: EventProcType = {--on rootTQ SELECT event.type FROM finalEvent => { ev: Xl.FinalEvent ~ NARROW[event]; shell: Widget ~ NARROW[clientData]; IF ~ev.refCountTransition AND shell.connection=ev.connection AND shell.state<=screened THEN { shellIP: ShellInstPart ~ GetShellInstPart[shell]; closure: REF Closure ¬ shellIP.connectionDiedClosure; XTkFriends.PreStopFastAccess[shell, errorConnection]; shellIP.connection ¬ NIL; IF closure=NIL THEN DestroyShell[shell] ELSE closure.proc[shell, closure.registerData, $connectionDied, ev]; }; }; ENDCASE => {}; }; shellRootEvents: Xl.EventFilter ~ Xl.CreateEventFilter[destroyNotify, configureNotify]; shellOtherEvents: Xl.EventFilter ~ Xl.CreateEventFilter[clientMessage]; OtherShellEvents: <> Xl.EventProcType = { shell: Widget ~ NARROW[clientData]; shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF shell.state>realized OR shell.fastAccessAllowed#ok THEN RETURN; SELECT event.type FROM clientMessage => { client: Xl.ClientMessageEvent ~ NARROW[event]; IF client.window#shell.window OR client.format#32 THEN RETURN; IF client.typeAtom#shellIP.wmProtocolsAtom THEN RETURN; SELECT client.w[0] FROM shellIP.cachedWmAtom => { SetFocus[shell, [client.w[1]], NIL]; }; Xl.MakeAtom[shell.connection, "WM_DELETE_WINDOW"] => { IF shellIP.deletionProtocol THEN { closure: REF Closure ¬ shellIP.wmDeletionClosure; IF closure=NIL THEN DestroyByWindowManager[shell, NIL, $wmDeleteWindow, client] ELSE closure.proc[shell, closure.registerData, $wmDeleteWindow, client]; }; }; ENDCASE => RETURN; }; ENDCASE => {}; }; ShellEventLR: <> Xl.EventProcType = { ENABLE ABORTED => GOTO oops; shell: Widget ~ NARROW[clientData]; shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF shell.state>realized OR shell.fastAccessAllowed#ok THEN RETURN; SELECT event.type FROM configureNotify => { g: Geometry; cn: ConfigureNotifyEvent ~ NARROW[event]; IF shellIP.crazyShell THEN { IF cn.window#shellIP.parentWindow THEN RETURN; } ELSE { IF cn.window#shell.window THEN RETURN; shell.actual.pos ¬ cn.geometry.pos; shell.actual.borderWidth ¬ cn.geometry.borderWidth; }; IF shell.actual.size#cn.geometry.size THEN { g ¬ [size: cn.geometry.size, pos: [dontUse, dontUse], borderWidth: dontUse]; <<--Note: The sizing has not yet happened! .>> ShellCheatConfigureLR[shell, g]; }; }; destroyNotify => { d: Xl.DestroyNotifyEvent ~ NARROW[event]; SELECT d.window FROM shellIP.parentWindow, shell.window => { closure: REF Closure ¬ shellIP.windowDiedClosure; IF shell.connection#d.connection OR shell.state>screened THEN RETURN; XTkFriends.PreStopFastAccess[shell, errorWindow]; IF closure=NIL THEN DestroyShell[shell] ELSE closure.proc[shell, closure.registerData, $destroyNotify, d]; }; ENDCASE => {} }; ENDCASE => {}; EXITS oops => NULL; }; ShellRemoveChildLR: XTk.RemoveChildProc = { shellIP: ShellInstPart ~ GetShellInstPart[widget]; oldChild: XTk.Widget ¬ shellIP.child; IF oldChild#NIL THEN { shellIP.child ¬ NIL; done ¬ TRUE; XTkFriends.ForgetScreenLR[oldChild]; }; }; AddChildLR: PROC [shell: XTk.Widget, newChild: Widget] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; oldChild: Widget ¬ shellIP.child; IF oldChild=newChild THEN RETURN; SELECT newChild.parent FROM NIL, shell => XTkFriends.AssignParentAndCheckScreenLR[newChild, shell]; ENDCASE => ERROR; IF oldChild#NIL THEN { shellIP.child ¬ NIL; XTkFriends.OrphanizeLR[oldChild, normal]; }; IF newChild.s.mapping=dontUse THEN newChild.s.mapping ¬ mapped; shellIP.child ¬ newChild; NoteChildChange[shell]; XTkFriends.ReconfigureChildrenLR[shell]; }; ShellInternalEnumerateChildren: XTk.InternalEnumerateChildrenProc = { child: XTk.Widget ¬ ShellChild[self]; IF child#NIL AND child.state> XTk.WidgetNotifyProc = { IF widget.fastAccessAllowed=ok THEN { XTkFriends.PreStopFastAccess[widget, normal]; IF widget.actualMapping=mapped THEN { Xl.UnmapWindow[widget.connection, widget.window, XTkPrivate.detailsForNoErrors]; }; }; DestroyShell[widget]; }; ShellChild: PROC [shell: ShellWidget] RETURNS [Widget¬NIL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; RETURN [shellIP.child]; }; ShellPreferredSizeLR: PreferredSizeProc = { child: Widget = ShellChild[widget]; maySkip[x] ¬ TRUE; maySkip[y] ¬ TRUE; IF widget.s.geometry.size.width > 0 THEN { maySkip[w] ¬ TRUE; proposed.size.width ¬ widget.s.geometry.size.width; }; IF widget.s.geometry.size.height > 0 THEN { maySkip[h] ¬ TRUE; proposed.size.height ¬ widget.s.geometry.size.height; }; IF widget.s.geometry.pos.x # dontUse THEN { <> proposed.pos.x ¬ widget.s.geometry.pos.x; }; IF widget.s.geometry.pos.y # dontUse THEN { <> proposed.pos.y ¬ widget.s.geometry.pos.y; }; IF widget.s.geometry.borderWidth # dontUse THEN { maySkip[b] ¬ TRUE; proposed.borderWidth ¬ widget.s.geometry.borderWidth; }; IF child = NIL OR (maySkip[w] AND maySkip[h] AND maySkip[b]) THEN RETURN [proposed] ELSE { g: Geometry ¬ XTkFriends.PreferredSizeLR[child, NIL, proposed, maySkip]; IF g.borderWidth<0 THEN g.borderWidth ¬ 0; preferred.size.width ¬ SELECT TRUE FROM widget.s.geometry.size.width>0 => widget.s.geometry.size.width, g.size.width>0 => g.size.width + g.borderWidth*2, ENDCASE => dontUse; preferred.size.height ¬ SELECT TRUE FROM widget.s.geometry.size.height>0 => widget.s.geometry.size.height, g.size.height>0 => g.size.height + g.borderWidth*2, ENDCASE => dontUse; }; preferred.pos ¬ widget.s.geometry.pos; preferred.borderWidth ¬ widget.s.geometry.borderWidth; }; EnsureRootThread: PROC [inq: Xl.TQ] RETURNS [tq: Xl.TQ] = { IF inq=NIL THEN { tq ¬ Xl.CreateTQ[$root, XTk.rootLockingOrder, FALSE] } ELSE { tq ¬ inq; IF Xl.GetLockOrderNum[tq]> XTk.AddTemporaryMatch[widget, [proc: ShellEventLR, handles: shellRootEvents, tq: widget.rootTQ, data: widget], [structureNotify: TRUE]]; <<--my parents events: we need to know about resizing>> AddDispatch[connection, shellIP.parentWindow, NEW[MatchRep ¬ [proc: ShellEventLR, handles: shellRootEvents, tq: widget.rootTQ, data: widget]], [structureNotify: TRUE]]; widget.window ¬ Xl.CreateWindow[c: connection, matchList: XTkFriends.CollectMatchesLR[widget], parent: shellIP.parentWindow, geometry: widget.actual, depth: widget.depth, attributes: widget.attributes]; ShellPropagateConfigureLR[widget, TRUE]; IF widget.actualMapping=mapped THEN { Xl.MapWindow[connection, widget.window, XTkPrivate.detailsForFlushNoErrors]; }; }; skipPos: GeometryRequest ~ [TRUE, TRUE, FALSE, FALSE, FALSE]; NormalShellCreateWindowLR: PROC [widget: Widget, shellIP: ShellInstPart] = { g: Geometry; cheatWM: BOOL; goodSize, goodPos: BOOL ¬ TRUE; connection: Xl.Connection ~ widget.connection; hints: REF XTkShellWidgets.ICCCMHints ~ GetHints[widget]; IF shellIP.parentWindow=nullWindow THEN { shellIP.parentWindow ¬ Xl.DefaultScreen[connection].root; }; shellIP.wmProtocolsAtom ¬ Xl.MakeAtom[connection, "WM_PROTOCOLS"]; IF widget.s.geometry.borderWidth<0 THEN widget.s.geometry.borderWidth ¬ 0; g ¬ XTkFriends.PreferredSizeLR[widget: widget, proposed: widget.s.geometry, maySkip: skipPos];--exceptional to query its own preference IF g.size.width <= 0 THEN {g.size.width ¬ 40; goodSize ¬ FALSE}; IF g.size.height <= 0 THEN {g.size.width ¬ 20; goodSize ¬ FALSE}; IF g.borderWidth < 0 THEN {g.borderWidth ¬ 0}; widget.s.geometry.size ¬ g.size; widget.s.geometry.borderWidth ¬ g.borderWidth; IF goodSize THEN { hints.wmNormalHints.obsoleteSz ¬ widget.s.geometry.size; hints.wmNormalHints.clientSize ¬ TRUE; hints.wmNormalHintsChanged ¬ TRUE; }; cheatWM ¬ widget.attributes.overrideRedirect=illegal AND XlConventions.WMQueryPosition[connection]; IF cheatWM THEN widget.attributes.overrideRedirect ¬ true; IF widget.s.geometry.pos.x = dontUse THEN { widget.s.geometry.pos.x ¬ Random.ChooseInt[max: 500]; goodPos ¬ FALSE }; IF widget.s.geometry.pos.y = dontUse THEN { widget.s.geometry.pos.y ¬ Random.ChooseInt[max: 400]; goodPos ¬ FALSE }; IF goodPos THEN { hints.wmNormalHints.obsoletePos ¬ widget.s.geometry.pos; hints.wmNormalHintsChanged ¬ TRUE; }; XTk.AddTemporaryMatch[widget, [proc: ShellEventLR, handles: shellRootEvents, tq: widget.rootTQ, data: widget]]; XTk.AddTemporaryMatch[widget, [proc: OtherShellEvents, handles: shellOtherEvents, tq: Xl.CreateTQ[], data: widget]]; widget.actual ¬ widget.s.geometry; widget.window ¬ Xl.CreateWindow[c: connection, matchList: XTkFriends.CollectMatchesLR[widget], parent: shellIP.parentWindow, geometry: widget.actual, depth: widget.depth, attributes: widget.attributes]; ProtectedUpdateHints[widget]; ShellPropagateConfigureLR[widget, TRUE]; --size will probably change later if window manager orders different size... IF widget.actualMapping=mapped THEN { Xl.MapWindow[connection, widget.window]; }; IF cheatWM THEN { widget.attributes.overrideRedirect ¬ illegal; Xl.ChangeWindowAttributes[connection, widget.window, [overrideRedirect: false]]; }; IF shellIP.childrenWithColorMap#NIL THEN TrackColorMap[widget, NIL]; }; ShellConfigureLR: ConfigureProc = { <<--Note (except for creation): >> <<-- Ordering new size with Configure is a rare event >> <<-- Normally sizing has already happened by window manager! >> existW: BOOL ¬ widget.actualMapping> XTkFriends.SimpleConfigureOneLevelLR[widget: widget, geometry: geometry, mapping: mapping, reConsiderChildren: reConsiderChildren]; ShellPropagateConfigureLR[widget, reConsiderChildren]; XTkFriends.CallNotifiers[widget, $ShellPostReconfigure]; }; IF widget.fastAccessAllowed=ok THEN Xl.Flush[widget.connection]; }; ShellPropagateConfigureLR: PROC [widget: Widget, reConsiderChildren: BOOL] = { child: Widget = ShellChild[widget]; IF child#NIL THEN { g: Geometry ¬ [size: widget.actual.size, pos: [0, 0], borderWidth: BorderWidth[child]]; childMap: Mapping ¬ IF reConsiderChildren THEN child.s.mapping ELSE dontUse; IF g.size.width<=0 THEN g.size.width ¬ 1; IF g.size.height<=0 THEN g.size.height ¬ 1; IF reConsiderChildren THEN XTk.SetWidgetFlag[widget, XTk.mustReConsiderChildren, FALSE]; XTkFriends.ConfigureLR[child, g, childMap, reConsiderChildren]; }; }; ShellInstPart: TYPE = REF ShellInstPartRec; ShellInstPartRec: TYPE = RECORD [ child: XTk.Widget ¬ NIL, originalRootTQ: Xl.TQ ¬ NIL, connection: REF ¬ NIL, parentWindow: Window ¬ Xl.nullWindow, className: ATOM ¬ NIL, iconName: ROPE ¬ NIL, packageName: ROPE ¬ NIL, shortName: ROPE ¬ NIL, finallyUnmapped: BOOL ¬ FALSE, crazyShell: BOOL ¬ FALSE, --interoperability thing: parentWindow # root hints: REF XTkShellWidgets.ICCCMHints ¬ NIL, <<--normal shells only>> deletionProtocol: BOOL ¬ FALSE, wmDeletionClosure: REF Closure ¬ NIL, windowDiedClosure: REF Closure ¬ NIL, connectionDiedClosure: REF Closure ¬ NIL, focusGoal: REF ¬ NIL, focusTime: TimeStamp ¬ [0], dontQueryGeometry: BOOL ¬ FALSE, childrenWithColorMap: LIST OF Widget ¬ NIL, wmProtocolsAtom: XAtom ¬ [0], --speed up ! connectionWatcherMatch: Xl.Match ¬ NIL, cachedWmAtom: XAtom ¬ [0] ]; IsARoot: PROC [connection: Connection, window: Window] RETURNS [BOOL¬FALSE] = { FOR i: INT IN [0..ScreenCount[connection]) DO IF NthScreen[connection, i].root=window THEN RETURN [TRUE]; ENDLOOP }; ShellInitInstPart: InitInstancePartProc = { shellIP: ShellInstPart ~ NEW[ShellInstPartRec]; XTkFriends.AssignInstPart[widget, shellClass, shellIP]; IF widget.parent#NIL THEN ERROR; }; Closure: TYPE = RECORD [proc: XTk.WidgetNotifyProc, registerData: REF ¬ NIL]; --use a ref to gain atomicity RegisterCallConnectionDied: PUBLIC PROC [shell: ShellWidget, proc: WidgetNotifyProc, registerData: REF ¬ NIL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; closure: REF Closure ~ IF proc#NIL THEN NEW[Closure ¬ [proc, registerData]] ELSE NIL; shellIP.connectionDiedClosure ¬ closure; }; <<>> RegisterCallWindowDied: PUBLIC PROC [shell: ShellWidget, proc: WidgetNotifyProc, registerData: REF ¬ NIL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; closure: REF Closure ~ IF proc#NIL THEN NEW[Closure ¬ [proc, registerData]] ELSE NIL; shellIP.windowDiedClosure ¬ closure; }; RegisterCallWMDeleteWindow: PUBLIC PROC [shell: ShellWidget, proc: XTk.WidgetNotifyProc, registerData: REF ¬ NIL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; closure: REF Closure ~ IF proc#NIL THEN NEW[Closure ¬ [proc, registerData]] ELSE NIL; shellIP.wmDeletionClosure ¬ closure; }; GetHints: PUBLIC PROC [shell: ShellWidget] RETURNS [REF XTkShellWidgets.ICCCMHints] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF shellIP.hints=NIL THEN { shellIP.hints ¬ NEW[XTkShellWidgets.ICCCMHints]; shellIP.hints.wmHints.initialState ¬ 1; }; RETURN [shellIP.hints]; }; <<>> UpdateHints: PUBLIC PROC [shell: ShellWidget] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; action: PROC = {ProtectedUpdateHints[shell]}; IF shell.fastAccessAllowed#ok THEN RETURN; Xl.CallWithLock[shellIP.originalRootTQ, action]; }; ProtectedUpdateHints: PROC [shell: ShellWidget] = { c: Xl.Connection ¬ shell.connection; shellIP: ShellInstPart ~ GetShellInstPart[shell]; h: REF XTkShellWidgets.ICCCMHints ~ GetHints[shell]; IF c=NIL OR h=NIL OR shell.fastAccessAllowed#ok THEN RETURN; IF h.wmHintsChanged THEN { h.wmHintsChanged ¬ FALSE; h.wmHints.windowGroup ¬ ToWindow[h.windowGroup]; XlConventions.SetWMHints[c, shell.window, h­.wmHints]; }; IF h.wmNormalHintsChanged THEN { h.wmNormalHintsChanged ¬ FALSE; XlConventions.SetWMNormalHints[c, shell.window, h­.wmNormalHints]; }; IF h.iconNameChanged THEN { h.iconNameChanged ¬ FALSE; XlConventions.SetIconName[c, shell.window, h.iconName]; }; IF h.windowHeaderChanged THEN { h.windowHeaderChanged ¬ FALSE; XlConventions.SetWindowName[c, shell.window, h.windowHeader]; }; IF h.wmClassChanged THEN { h.wmClassChanged ¬ FALSE; XlConventions.SetWMClass[c, shell.window, h.wmClassClass, h.wmClassInstance]; }; IF h.transientForChanged THEN { h.transientForChanged ¬ FALSE; XlConventions.SetWMTransient[c, shell.window, ToWindow[h.transientFor]]; }; IF h.protocolsChanged THEN { h.protocolsChanged ¬ FALSE; XlConventions.SetWMProtocols[c, shell.window, h.protocols]; }; Xl.Flush[c, TRUE]; }; ForgetHints: PROC [h: REF XTkShellWidgets.ICCCMHints] = { IF h#NIL THEN { h.wmHints.windowGroup ¬ Xl.nullWindow; h.wmHints.iconMask ¬ Xl.nullPixmap; h.wmHints.iconPixmap ¬ Xl.nullPixmap; h.wmHints.iconWindow ¬ Xl.nullWindow; h.wmHintsChanged ¬ h.wmHints#[]; h.wmNormalHintsChanged ¬ h.wmNormalHints#[]; h.windowHeaderChanged ¬ h.windowHeader#NIL; h.iconNameChanged ¬ h.iconName#NIL; h.transientForChanged ¬ h.transientFor#NIL; h.wmClassChanged ¬ h.wmClassInstance#NIL OR h.wmClassClass#NIL; h.protocolsChanged ¬ h.protocols#NIL; }; }; CreateShell: PUBLIC PROC [widgetSpec: WidgetSpec, child: Widget ¬ NIL, windowHeader: ROPE ¬ NIL, iconName: ROPE ¬ NIL, className: ATOM ¬ NIL, packageName: ROPE ¬ NIL, shortName: ROPE ¬ NIL, rootTQ: TQ ¬ NIL, dontQueryGeometry: BOOL ¬ FALSE, deletionProtocol: BOOL ¬ TRUE, focusProtocol: BOOL ¬ TRUE, standardMigration: BOOL ¬ TRUE] RETURNS [widget: Widget] = { widget ¬ XTk.CreateWidget[widgetSpec, shellClass]; rootTQ ¬ EnsureRootThread[rootTQ]; BEGIN shellIP: ShellInstPart ~ GetShellInstPart[widget]; shellIP.originalRootTQ ¬ rootTQ; shellIP.crazyShell ¬ FALSE; shellIP.dontQueryGeometry ¬ dontQueryGeometry; shellIP.className ¬ (IF className#NIL THEN className ELSE $Shell); shellIP.deletionProtocol ¬ deletionProtocol; shellIP.packageName ¬ packageName; IF widgetSpec.instName=NIL THEN { IF ~Rope.IsEmpty[shortName] THEN widgetSpec.instName _ Atom.MakeAtom[shortName]; } ELSE { IF Rope.IsEmpty[shortName] THEN shortName _ Atom.GetPName[widgetSpec.instName]; }; shellIP.shortName ¬ shortName; shellIP.iconName ¬ iconName; END; BEGIN hints: REF XTkShellWidgets.ICCCMHints ¬ GetHints[widget]; IF windowHeader#NIL THEN { hints.windowHeader ¬ windowHeader; hints.windowHeaderChanged ¬ TRUE; }; IF iconName#NIL THEN { hints.iconName ¬ iconName; hints.iconNameChanged ¬ TRUE; }; IF className#NIL AND hints.wmClassClass=NIL THEN { hints.wmClassClass ¬ Atom.GetPName[className]; hints.wmClassChanged ¬ TRUE; }; IF focusProtocol THEN SetFocusMethod[shell: widget, focusProtocol: true]; IF deletionProtocol THEN { hints.protocols ¬ AddRope["WM_DELETE_WINDOW", hints.protocols]; hints.protocolsChanged ¬ TRUE; }; END; IF child#NIL THEN AddChildLR[shell: widget, newChild: child]; IF standardMigration THEN XTkMigration.RegisterMigrator[widget, XTkMigration.StandardMigrator]; }; ApplicationClassName: PUBLIC PROC [shell: ShellWidget] RETURNS [className: ATOM] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; RETURN [shellIP.className] }; <<>> BindScreenShell: PUBLIC PROC [shell: ShellWidget, connection: REF ¬ NIL, parentWindow: Xl.Window ¬ Xl.nullWindow] = { MyCreateConnection: PROC [r: Rope.ROPE ¬ NIL, atom: ATOM ¬ NIL] = { c ¬ Xl.CreateConnection[server: r, applicationKey: atom]; refCountObject ¬ NIL; mustDecrementRefCount ¬ TRUE; }; refCountObject: REF ¬ NIL; mustDecrementRefCount: BOOL ¬ FALSE; c: Xl.Connection; screenDepth: Xl.ScreenDepth; shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF shellIP.connection#NIL THEN ERROR; --already bound shell.connection ¬ NIL; IF connection=NIL THEN { <<--This is a convention by which the environment gets a chance to fill in the connection, or, make a readable error message.>> XTkNotification.CallAll[$GetShellConnection, shell, shellIP.className]; c ¬ shellIP.connection ¬ shell.connection; <<--The created connection has a ref count increased which needs to be undone >> IF Xl.Alive[c] THEN { refCountObject ¬ shell; mustDecrementRefCount ¬ TRUE; }; }; IF ~Xl.Alive[c] THEN { IF connection=NIL THEN MyCreateConnection[] ELSE WITH connection SELECT FROM a: ATOM => MyCreateConnection[NIL, a]; r: Rope.ROPE => MyCreateConnection[r]; rt: REF READONLY TEXT => MyCreateConnection[Rope.FromRefText[rt]]; xc: Xl.Connection => c ¬ xc; ENDCASE => ERROR; IF ~Xl.Alive[c] THEN { err: REF Xl.EventRep.errorNotify ~ NEW[Xl.EventRep.errorNotify]; err.connection ¬ c; err.errorKind ¬ requestFromDeadConnection; err.explanation ¬ "XTk.BindScreenShell using dead connection"; ERROR Xl.XError[err]; }; shell.connection ¬ shellIP.connection ¬ c; }; shellIP.parentWindow ¬ parentWindow; screenDepth ¬ Xl.QueryScreenDepth[c, shellIP.parentWindow]; IF parentWindow=Xl.nullWindow THEN { <> screen: Xl.Screen ¬ screenDepth.screen; IF screenDepth.depth#1 AND screenDepth.depth#8 THEN { FOR sdl: Xl.ScreenDepthL ¬ screen.screenDepthL, sdl.rest WHILE sdl#NIL DO IF sdl.first.screen=screen AND sdl.first.nVisualTypes>0 THEN { IF sdl.first.depth=1 OR sdl.first.depth=8 THEN { screenDepth ¬ sdl.first }; }; ENDLOOP; }; }; XTkFriends.BindScreenLR[widget: shell, rootTQ: shellIP.originalRootTQ, screen: screenDepth.screen, screenDepth: screenDepth]; IF mustDecrementRefCount THEN Xl.DecRefCount[c, refCountObject]; }; <<>> ShellBindScreenLX: XTk.BindScreenProc = { shellIP: ShellInstPart ~ GetShellInstPart[widget]; shellIP.connectionWatcherMatch ¬ NEW[Xl.MatchRep ¬ [proc: ConnectionDiedHandler, handles: connectionDeadSet, tq: rootTQ, data: widget]]; XlDispatch.AddMatch[screen.connection, Xl.nullWindow, shellIP.connectionWatcherMatch, Xl.unspecifiedEvents, XTkPrivate.detailsForNoErrors]; Xl.IncRefCount[screen.connection, widget]; IF ~shellIP.dontQueryGeometry THEN { g: Xl.Geometry ¬ XTkDB.GetGeometryFromDB[widget]; IF g.size.width>0 THEN widget.s.geometry.size.width ¬ g.size.width; IF g.size.height>0 THEN widget.s.geometry.size.height ¬ g.size.height; IF g.pos.x>=0 THEN widget.s.geometry.pos.x ¬ g.pos.x; IF g.pos.y>=0 THEN widget.s.geometry.pos.y ¬ g.pos.y; IF g.borderWidth>=0 THEN widget.s.geometry.borderWidth ¬ g.borderWidth; IF g.size.width>0 AND g.size.height>0 THEN { h: REF XTkShellWidgets.ICCCMHints ~ GetHints[widget]; h.wmNormalHints.userSize ¬ h.wmNormalHints.clientSize ¬ TRUE; h.wmNormalHintsChanged ¬ TRUE; }; IF g.pos.y>=0 AND g.pos.x>=0 THEN { h: REF XTkShellWidgets.ICCCMHints ~ GetHints[widget]; h.wmNormalHints.userPos ¬ h.wmNormalHints.clientPos ¬ TRUE; h.wmNormalHintsChanged ¬ TRUE; }; }; }; ForgetScreenShell: PUBLIC PROC [shell: ShellWidget] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; action: PROC = { shellIP.connection ¬ NIL; XTkFriends.ForgetScreenLR[shell] }; Xl.CallWithLock[shellIP.originalRootTQ, action]; }; RefCountData: TYPE = RECORD [c: Xl.Connection, object: REF]; ShellForgetScreenLR: XTk.TerminateProc = { c: Xl.Connection ¬ widget.connection; shellIP: ShellInstPart ~ GetShellInstPart[widget]; ForgetHints[shellIP.hints]; IF Xl.Alive[c] THEN { rcd: REF RefCountData ~ NEW[RefCountData ¬ [c, widget]]; --Save the connection-object pair as the original widget.connection might change before QueuedDecrementRefCount is done. wm: Xl.Match ¬ shellIP.connectionWatcherMatch; IF wm#NIL THEN { XlDispatch.RemoveMatch[c, Xl.nullWindow, wm, XTkPrivate.detailsForNoErrors]; shellIP.connectionWatcherMatch ¬ NIL; }; <<--enqueued to be last thing on rootTQ, and, connection stays alive for our continuation (e.g. super classes TerminateProc). >> Xl.Enqueue[tq: widget.rootTQ, proc: QueuedDecrementRefCount, data: rcd]; }; }; QueuedDecrementRefCount<>: Xl.EventProcType = { rcd: REF RefCountData ¬ NARROW[clientData]; Xl.DecRefCount[rcd.c, rcd.object]; }; CreateInteroperabilityShell: PUBLIC PROC [widgetSpec: WidgetSpec ¬ [], child: Widget ¬ NIL, className: ATOM ¬ NIL, rootTQ: TQ ¬ NIL] RETURNS [widget: Widget] = { widget ¬ XTk.CreateWidget[widgetSpec, shellClass]; rootTQ ¬ EnsureRootThread[rootTQ]; BEGIN shellIP: ShellInstPart ~ GetShellInstPart[widget]; shellIP.crazyShell ¬ TRUE; shellIP.originalRootTQ ¬ rootTQ; shellIP.dontQueryGeometry ¬ TRUE; shellIP.className ¬ (IF className#NIL THEN className ELSE $InterOpShell); END; IF child#NIL THEN AddChildLR[shell: widget, newChild: child]; }; BindInteroperabilityShell: PUBLIC PROC [shell: ShellWidget, connection: Xl.Connection, foreignParent: Xl.Window] = { BindScreenShell[shell, connection, foreignParent]; }; <<>> SetShellChild: PUBLIC PROC [shell: ShellWidget, child: Widget] = { action: PROC = { IF child.s.mapping=dontUse THEN child.s.mapping ¬ mapped; AddChildLR[shell: shell, newChild: child] }; shellIP: ShellInstPart ~ GetShellInstPart[shell]; Xl.CallWithLock[shellIP.originalRootTQ, action]; }; ConfigureRec: TYPE = RECORD [widget: Widget, geometry: Xl.Geometry, mapping: Mapping, reConsiderChildren: BOOL]; ForkRealizeShell: PUBLIC PROC [shell: ShellWidget, geometry: Xl.Geometry, mapping: Mapping, reConsiderChildren: BOOL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; cr: REF ConfigureRec ¬ NEW[ConfigureRec ¬ [shell, geometry, mapping, reConsiderChildren]]; Xl.Enqueue[shellIP.originalRootTQ, ForkedRealizeShell, cr]; }; <<>> ForkedRealizeShell<>: Xl.EventProcType = { cr: REF ConfigureRec ¬ NARROW[clientData]; ReallyRealizeShellLR[cr.widget, cr.geometry, cr.mapping, cr.reConsiderChildren]; }; RealizeShell: PUBLIC PROC [shell: ShellWidget, geometry: Xl.Geometry, mapping: Mapping, reConsiderChildren: BOOL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; action: PROC = {ReallyRealizeShellLR[shell, geometry, mapping, reConsiderChildren]}; Xl.CallWithLock[shellIP.originalRootTQ, action]; }; <<>> ReallyRealizeShellLR: PROC [shell: ShellWidget, geometry: Xl.Geometry, mapping: Mapping, reConsiderChildren: BOOL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF mapping=dontUse THEN { IF shell.actualMapping>=dontUse THEN mapping ¬ mapped }; IF shell.state>screened THEN BindScreenShell[shell]; XTkIcon.SetIconName[shell, TRUE, shellIP.iconName]; XTkIcon.SetIconMask[shell, TRUE, shellIP.packageName, shellIP.shortName]; XTkFriends.ConfigureLR[shell, geometry, mapping, reConsiderChildren]; BEGIN c: Xl.Connection ¬ shell.connection; IF Xl.Alive[c] THEN Xl.Flush[c, TRUE]; END; }; DestroyShell: PUBLIC PROC [shell: ShellWidget] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; action: PROC = {XTkFriends.DestroyWidgetLR[shell]}; Xl.CallWithLock[shellIP.originalRootTQ, action]; }; ShellPreStopFastAccess: TerminateProc = { shellIP: ShellInstPart ~ GetShellInstPart[widget]; shellIP.focusTime ¬ [0]; IF ~shellIP.finallyUnmapped AND widget.window#nullWindow THEN { shellIP.finallyUnmapped ¬ TRUE; IF reason=normal AND Xl.Alive[widget.connection] THEN Xl.UnmapWindow[widget.connection, widget.window, XTkPrivate.detailsForFlushSoonNoErrors]; }; WITH shellIP.focusGoal SELECT FROM w: XTk.Widget => {}; ENDCASE => shellIP.focusGoal ¬ NIL; }; GetShellInstPart: PROC [w: Widget] RETURNS [ShellInstPart] = INLINE { RETURN [ NARROW[XTkFriends.InstPart[w, shellClass]] ]; }; EntryTrackCM: ENTRY PROC [shell: ShellWidget, shellIP: ShellInstPart, w: Widget] = { ENABLE UNWIND => NULL; IF shellIP#NIL THEN { cnt: INT ¬ 1; lag: LIST OF Widget ¬ shellIP.childrenWithColorMap; IF w#NIL THEN { lag ¬ CONS[w, lag]; <<--prevent duplications>> FOR l: LIST OF Widget ¬ lag, lag.rest WHILE l#NIL DO IF l.first=w THEN RETURN; ENDLOOP }; WHILE lag#NIL AND lag.first.state>=dead DO lag ¬ lag.rest; ENDLOOP; shellIP.childrenWithColorMap ¬ lag; IF lag=NIL THEN RETURN; DO IF lag.rest=NIL THEN EXIT; IF lag.rest.first.state>=dead THEN lag.rest ¬ lag.rest.rest ELSE {lag ¬ lag.rest; cnt ¬ cnt+1} ENDLOOP; IF shell.fastAccessAllowed=ok THEN { d: REF Xl.Card32Sequence ¬ MakeColorMapData[shellIP, cnt]; PutTheColorMapProp[shell, d ! Xl.XError => CONTINUE]; buffer ¬ d; } }; }; buffer: REF Xl.Card32Sequence ¬ NIL; MakeColorMapData: INTERNAL PROC [shellIP: ShellInstPart, cnt: INT] RETURNS [d: REF Xl.Card32Sequence ¬ NIL] = { IF cnt>0 THEN { lw: LIST OF Widget ¬ shellIP.childrenWithColorMap; IF buffer#NIL AND buffer.leng>=cnt THEN {d ¬ buffer; buffer ¬ NIL} ELSE d ¬ NEW[Card32Sequence[cnt]]; FOR i: INT IN [0..cnt) DO IF lw#NIL THEN {d[i] ¬ lw.first.window; lw ¬ lw.rest} ELSE d[i] ¬ Xl.nullWindow; ENDLOOP }; }; PutTheColorMapProp: PROC [shell: ShellWidget, value: REF Xl.Card32Sequence] = { IF value#NIL THEN { propertyKey: XAtom ¬ Xl.MakeAtom[shell.connection, "WM_COLORMAP_WINDOWS"]; Xl.ChangeProperty[shell.connection, shell.window, propertyKey, XlPredefinedAtoms.window, replace, value]; }; }; TrackColorMap: PUBLIC PROC [shell: ShellWidget, w: Widget] = { IF shell=NIL THEN shell ¬ XTk.RootWidget[w]; IF shell#NIL AND shell.fastAccessAllowed=ok THEN { shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF shellIP.crazyShell THEN RETURN; --don't know how... EntryTrackCM[shell, shellIP, w]; }; }; ShellClassName: ClassNameProc = { shellIP: ShellInstPart ~ GetShellInstPart[widget]; RETURN [shellIP.className]; }; AddRope: PROC [r: Rope.ROPE, list: LIST OF Rope.ROPE] RETURNS [LIST OF Rope.ROPE] = { IF ~RopeList.Memb[list, r] THEN list ¬ CONS[r, list]; RETURN [list] }; SetFocusMethod: PUBLIC PROC [shell: ShellWidget, focusProtocol, inputHint: Xl.BOOL3 ¬ illegal] = { h: REF XTkShellWidgets.ICCCMHints ¬ GetHints[shell]; IF focusProtocol#illegal THEN { wmTakeFocus: Rope.ROPE ¬ "WM_TAKE_FOCUS"; SELECT focusProtocol FROM true => { h.protocols ¬ AddRope[wmTakeFocus, h.protocols]; h.protocolsChanged ¬ TRUE }; false => { h.protocols ¬ RopeList.DRemove[h.protocols, wmTakeFocus]; h.protocolsChanged ¬ TRUE }; ENDCASE => {}; }; IF inputHint#illegal THEN { SELECT inputHint FROM true => {h.wmHints.input ¬ 1; h.wmHintsChanged ¬ TRUE}; false => {h.wmHints.input ¬ 0; h.wmHintsChanged ¬ TRUE}; ENDCASE => {}; }; UpdateHints[shell]; }; SetFocusTarget: PUBLIC PROC [shell: ShellWidget, child: REF, time: Xl.TimeStamp] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF ValidTime[shellIP.focusTime, time] THEN shellIP.focusGoal ¬ child }; ValidTime: PROC [lastTime, eventTime: Xl.TimeStamp] RETURNS [BOOL] = { RETURN [ Xl.Period[from: lastTime, to: eventTime]>=0 OR eventTime=Xl.currentTime OR lastTime=Xl.currentTime OR --this is it! We want to prevent invalid times. But we want to survive if a crazy server did not get an event for LAST[TimeStamp]/2. So we assume a 2 minutes is the maximum delay which invalid times could be caused due to unsynchronized nonsense Xl.Period[from: eventTime, to: lastTime]>120000 ] }; SetFocus: PUBLIC PROC [shell: ShellWidget, time: Xl.TimeStamp, child: REF] = { w: Window; shellIP: ShellInstPart ~ GetShellInstPart[shell]; IF ValidTime[shellIP.focusTime, time] THEN { IF child=NIL THEN child ¬ shellIP.focusGoal ELSE shellIP.focusGoal ¬ child; w ¬ ToWindow[child]; IF w#Xl.nullWindow THEN { shellIP.focusTime ¬ time; IF shell.fastAccessAllowed=ok THEN Xl.SetInputFocus[shell.connection, w, parent, time, XTkPrivate.detailsForFlushNoErrors]; }; }; }; FocusTime: PUBLIC PROC [shell: ShellWidget] RETURNS [Xl.TimeStamp] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; RETURN [shellIP.focusTime]; }; <> Iconify: PUBLIC PROC [shell: ShellWidget] = { <<--Forget about such things as using rootTQ. We never know iconic state atomically anyway since interactive actions of user through window manager are not synchronized.>> IF shell.state>=dead THEN RETURN; shell.s.mapping ¬ mapped; SetIconicHint[shell, TRUE]; --irrelevant if open or iconic, useful if was withdrawn... IF shell.state=realized AND shell.fastAccessAllowed=ok THEN { root: Xl.Window ¬ shell.screenDepth.screen.root; atom: Xl.XAtom ¬ Xl.MakeAtom[shell.connection, "WM_CHANGE_STATE"]; Xl.SendClientMessage32[c: shell.connection, destination: root, propagate: FALSE, eventMask: [substructureRedirect: TRUE, substructureNotify: TRUE], window: shell.window, type: atom, data: [3, 0, 0, 0, 0], details: XTkPrivate.detailsForFlushSoonNoErrors ]; }; <<--ELSE wont open and iconify shell; just make sure shell will be iconic on realization>> }; OpenIcon: PUBLIC PROC [shell: ShellWidget] = { <<--Forget about such things as using rootTQ. We never know iconic state atomically anyway since interactive actions of user through window manager are not synchronized.>> IF shell.state>=dead THEN RETURN; SetIconicHint[shell, FALSE]; --irrelevant if iconic or opened; useful if withdrawn... shell.s.mapping ¬ mapped; IF shell.state=realized AND shell.fastAccessAllowed=ok THEN { Xl.MapWindow[shell.connection, shell.window, XTkPrivate.detailsForFlushNoErrors]; <<--ELSE wont realize shell; just make sure shell will be opened on realization>> } }; WithDraw: PUBLIC PROC [shell: ShellWidget] = { <<--Forget about such things as using rootTQ. We never know iconic state atomically anyway since interactive actions of user through window manager are not synchronized.>> IF shell.state>=dead THEN RETURN; shell.s.mapping ¬ unmapped; IF shell.state=realized AND shell.fastAccessAllowed=ok THEN { root: Xl.Window ¬ shell.screenDepth.screen.root; eb: Xl.EventRep.unmapNotify; eb.eventWindow ¬ root; eb.window ¬ shell.window; eb.fromConfigure ¬ FALSE; Xl.UnmapWindow[shell.connection, shell.window]; Xl.SendEvent[c: shell.connection, destination: root, propagate: FALSE, eventMask: [substructureRedirect: TRUE, substructureNotify: TRUE], eventBody: eb, details: XTkPrivate.detailsForFlushSoonNoErrors]; }; <<--ELSE shell stays withdrawn; however OpenIcon and Iconify will be delayed until realization.>> }; SetIconicHint: PROC [shell: ShellWidget, iconic: BOOL] = { shellIP: ShellInstPart ~ GetShellInstPart[shell]; h: REF XTkShellWidgets.ICCCMHints ¬ GetHints[shell]; h.wmHints.initialState ¬ IF iconic THEN 3 ELSE 1; h.wmHintsChanged ¬ TRUE; UpdateHints[shell]; }; SetHeader: PUBLIC PROC [shell: ShellWidget, header: ROPE] = { h: REF XTkShellWidgets.ICCCMHints ¬ GetHints[shell]; h.windowHeader ¬ header; h.windowHeaderChanged ¬ TRUE; UpdateHints[shell]; }; <<>> SetIconName: PUBLIC PROC [shell: ShellWidget, header: ROPE] = { h: REF XTkShellWidgets.ICCCMHints ¬ GetHints[shell]; h.iconNameChanged ¬ TRUE; UpdateHints[shell]; }; END.