modified on Mon Feb 24 13:59:43 PST 1992 by muller
<*PRAGMA LL*>INTERFACE XEventQueue = RingBuffer(XEvent) END XEventQueue.
INTERFACE XEvent; IMPORT X; TYPE T = X.XEvent END XEvent.
INTERFACE XScrollQueue = RingBuffer(XScrollQElt) END XScrollQueue.
INTERFACE XScrollQElt; IMPORT PaintPrivate; TYPE T = PaintPrivate.ScrollRec END XScrollQElt.
UNSAFE MODULE; IMPORT X, VBT, TrestleClass, TrestleComm, Ctypes, M3toC, XEventQueue, XScreenType, Point, Rect, ProperSplit, Trestle, Thread, VBTClass, Axis, Text, Split, ScrnCursor, ScrnColorMap, VBTRep, XClientF, XPaint, TrestleImpl, ASCII, XProperties, TrestleOnX, XScrnCmap, Cstring, Unix, Xatom, Fmt, XScrnPxmp; FROM TrestleClass IMPORT Decoration; FROM XClientF IMPORT Child, SimpleWaitFor; FROM TrestleOnX IMPORT Enter, Exit; REVEAL T = XPaint.T BRANDED OBJECT OVERRIDES beChild := BeChild; replace := Replace; setcage := SetCage; sync := Sync; setcursor := SetCursor; newShape := NewShape; readUp := ReadUp; writeUp := WriteUp; redisplay := Redisplay; acquire := Acquire; release := Release; put := Put; forge := Forge; attach := Attach; decorate := Decorate; iconize := Iconize; overlap := Overlap; moveNear := MoveNear; installOffscreen := InstallOffscreen; setColorMap := SetColorMap; getScreens := GetScreens; allCeded := AllCeded; tickTime := TickTime; screenOf := ScreenOf; trestleId := TrestleID; windowId := WindowID; updateChalk := UpdateChalk; updateBuddies := UpdateBuddies; END; PROCEDURE XClient TrestleID (t: T; v: VBT.T): TEXT = BEGIN IF v = NIL THEN RETURN t.inst ELSE TYPECASE v.st OF NULL => | XScreenType.T (xst) => RETURN t.fullinst & "." & Fmt.Int(xst.screenID) ELSE END; RETURN t.fullinst & "." & Fmt.Int(X.XDefaultScreen(t.dpy)) END END TrestleID; PROCEDUREWindowID (<* UNUSED *> t: T; v: VBT.T): TEXT = BEGIN RETURN Fmt.Unsigned(TrestleOnX.Drawable(v), base := 10) END WindowID; PROCEDUREUpdateChalk (t: T; v: VBT.T; chalk: TEXT) = BEGIN TYPECASE v.upRef OF NULL => | Child (ur) => VAR ip: REF ARRAY OF CHAR; BEGIN ip := NEW(REF ARRAY OF CHAR, Text.Length(chalk) + 1); Text.SetChars(ip^, chalk); ip[LAST(ip^)] := ASCII.NUL; TRY Enter(t); TRY IF ur.w # X.None AND ur.xcage # X.None THEN XProperties.PutProp(t, ur.w, ToAtom(t, "XMUX_CHALKHOLDER"), Xatom.XA_STRING, ip^, 8); END FINALLY Exit(t) END EXCEPT TrestleComm.Failure => END END ELSE END END UpdateChalk; PROCEDUREUpdateBuddies (t: T; v: VBT.T; READONLY trsls, ids: ARRAY OF TEXT) = BEGIN TYPECASE v.upRef OF NULL => | Child (ur) => VAR trslProp, idProp := ""; tp, ip : REF ARRAY OF CHAR; BEGIN FOR i := 0 TO LAST(trsls) - 1 DO trslProp := trslProp & trsls[i] & "," END; IF NUMBER(trsls) > 0 THEN trslProp := trslProp & trsls[LAST(trsls)] END; tp := NEW(REF ARRAY OF CHAR, Text.Length(trslProp) + 1); Text.SetChars(tp^, trslProp); tp[LAST(tp^)] := ASCII.NUL; FOR i := 0 TO LAST(ids) DO idProp := idProp & ids[i] & " " END; ip := NEW(REF ARRAY OF CHAR, Text.Length(idProp) + 1); Text.SetChars(ip^, idProp); ip[LAST(ip^)] := ASCII.NUL; TRY Enter(t); TRY IF ur.w # X.None AND ur.xcage # X.None THEN XProperties.PutProp(t, ur.w, ToAtom(t, "XMUX_HOSTS"), Xatom.XA_STRING, tp^, 8); XProperties.PutProp( t, ur.w, ToAtom(t, "XMUX_IDS"), Xatom.XA_STRING, ip^, 8); END FINALLY Exit(t) END EXCEPT TrestleComm.Failure => END END ELSE END END UpdateBuddies; <* UNUSED *> PROCEDUREOutside (VAR cp: VBT.CursorPosition; v: VBT.T): BOOLEAN = VAR st: XScreenType.T := v.st; BEGIN cp.offScreen := cp.screen = st.screenID; RETURN VBT.Outside(cp, VBTClass.Cage(v)) END Outside; PROCEDUREBeChild (trsl: T; ch: VBT.T) RAISES {} = BEGIN IF ch.upRef = NIL THEN ch.upRef := NEW(Child, ch := ch, owns := NEW(XClientF.OwnsArray, 0)) ELSE WITH ur = NARROW(ch.upRef, Child) DO ur.ch := ch; ur.owns := NEW(XClientF.OwnsArray, 0) END END; ch.parent := trsl; END BeChild; PROCEDUREReplace (trsl: T; ch, new: VBT.T) RAISES {} = VAR ur: Child := ch.upRef; BEGIN IF new # NIL THEN Crash() END; TRY Enter(trsl); TRY IF ur.xcage = X.None THEN IF ur.captureOnWrite # NIL THEN VAR st : XScreenType.T := ch.st; pm : X.Pixmap := ur.w; dpy := trsl.dpy; id := ur.captureOnWrite.id; BEGIN IF XScrnPxmp.IsLazy(st, id) THEN IF Rect.Equal(XScrnPxmp.PixmapDomain(st, id), ch.domain) THEN XScrnPxmp.FinishCapture(st, id, pm); ur.w := X.None ELSE XPaint.ForceCapturePM(st, dpy, id); ur.captureOnWrite := NIL END END END END; IF ur.w # X.None THEN X.XFreePixmap(trsl.dpy, ur.w) END ELSE X.XDestroyWindow(trsl.dpy, ur.w) END FINALLY Exit(trsl) END EXCEPT X.Error, TrestleComm.Failure => (* skip *) END; XClientF.Delete(trsl, ch, ur) END Replace; PROCEDUREAttach (trsl: T; v: VBT.T) RAISES {} = BEGIN LOCK v DO LOCK trsl DO ProperSplit.Insert(trsl, NIL, v) END END END Attach; CONST DefaultWidth = 133.0; DefaultHeight = 100.0;
mm
PROCEDUREMoveNear (trsl: T; v, w: VBT.T) RAISES {TrestleComm.Failure} = VAR st : XScreenType.T; nw := Point.T{50, 50}; ch : Child; wtr: Trestle.T; id := Trestle.NoScreen; BEGIN LOOP IF w = NIL THEN EXIT END; IF NOT TrestleImpl.RootChild(w, wtr, w) THEN w := NIL; EXIT END; IF wtr = trsl THEN EXIT END; w := w.parent; END; IF w = v THEN w := NIL END; IF w # NIL THEN ch := w.upRef; IF w.st = NIL OR ch.xcage = X.None THEN w := NIL END END; IF w # NIL THEN st := w.st; Enter(trsl); TRY XClientF.ValidateNW(trsl, ch, st); nw := Point.Add(nw, ch.nw) FINALLY Exit(trsl) END; id := st.screenID END; InnerOverlap(trsl, v, id, nw, w # NIL) END MoveNear; PROCEDUREInstallOffscreen (trsl : T; v : VBT.T; width, height: CARDINAL; prefst : VBT.ScreenType) RAISES {TrestleComm.Failure} = VAR st := MatchScreenType(trsl, prefst); BEGIN CreateXPixmap(trsl, v, st, width, height) END InstallOffscreen; PROCEDUREMatchScreenType (trsl: T; prefst: VBT.ScreenType): XScreenType.T = BEGIN TYPECASE prefst OF XScreenType.T (xst) => IF xst # NIL AND xst.trsl = trsl THEN RETURN xst END ELSE END; IF prefst.depth = 1 THEN RETURN trsl.screens[0].bits ELSE RETURN trsl.screens[0] END END MatchScreenType; PROCEDUREScreenOf (trsl: T; ch: VBT.T; READONLY pt: Point.T): Trestle.ScreenOfRec RAISES {} = VAR ur : Child := ch.upRef; st : XScreenType.T := ch.st; res: Trestle.ScreenOfRec; BEGIN res.trsl := trsl; IF st = NIL OR ur = NIL OR ur.w # X.None AND ur.xcage = X.None THEN res.id := Trestle.NoScreen ELSE TRY Enter(trsl); TRY res.id := st.screenID; res.dom := st.rootDom; IF ur.w # X.None THEN XClientF.ValidateNW(trsl, ur, st); res.q := Point.Add(pt, ur.nw) ELSE res.q := pt END FINALLY Exit(trsl) END EXCEPT TrestleComm.Failure => res.id := Trestle.NoScreen END END; RETURN res END ScreenOf; PROCEDUREOverlap ( trsl: T; v : VBT.T; id : Trestle.ScreenID; READONLY nw : Point.T ) RAISES {TrestleComm.Failure} = BEGIN InnerOverlap(trsl, v, id, nw, TRUE) END Overlap; PROCEDUREInnerOverlap ( trsl : T; v : VBT.T; id : Trestle.ScreenID; READONLY nw : Point.T; knownPosition: BOOLEAN; iconic, userPosition := FALSE; prop, type := X.None; len, format := 0; addr: Ctypes.unsigned_char_star := NIL) RAISES {TrestleComm.Failure} = VAR st : XScreenType.T; alreadyMapped: BOOLEAN; BEGIN TRY LOCK trsl DO IF id < FIRST(trsl.screens^) OR id > LAST(trsl.screens^) THEN id := trsl.defaultScreen END; st := trsl.screens[id]; IF knownPosition OR v.st = NIL OR v.st = st THEN alreadyMapped := v.st = st ELSE alreadyMapped := FALSE; FOR i := FIRST(trsl.screens^) TO LAST(trsl.screens^) DO IF trsl.screens[i] = v.st THEN alreadyMapped := TRUE; st := v.st END END END END (* LOCK *); IF alreadyMapped THEN VAR ur : Child := v.upRef; xwc : X.XWindowChanges; mask := X.CWStackMode; BEGIN xwc.x := nw.h; xwc.y := nw.v; xwc.stack_mode := X.Above; IF knownPosition THEN INC(mask, X.CWX + X.CWY) END; Enter(trsl); TRY X.XConfigureWindow(trsl.dpy, ur.w, mask, ADR(xwc)); IF iconic AND NOT ur.decorated THEN X.XUnmapWindow(trsl.dpy, ur.w) ELSIF iconic THEN EVAL X.XIconifyWindow(trsl.dpy, ur.w, st.screenID) ELSE X.XMapWindow(trsl.dpy, ur.w) END FINALLY Exit(trsl) END END ELSE CreateXWindow( trsl, v, st, nw.h, nw.v, userPosition := userPosition, iconic := iconic, prop := prop, type := type, len := len, addr := addr, format := format) END EXCEPT X.Error => RAISE TrestleComm.Failure END END InnerOverlap; PROCEDUREIconize (trsl: T; v: VBT.T) RAISES {TrestleComm.Failure} = VAR alreadyMapped: BOOLEAN; BEGIN TRY alreadyMapped := v.st # NIL; IF alreadyMapped THEN VAR xst: XScreenType.T := v.st; ur : Child := v.upRef; BEGIN Enter(trsl); TRY IF NOT ur.decorated THEN X.XUnmapWindow(trsl.dpy, ur.w) ELSE EVAL X.XIconifyWindow(trsl.dpy, ur.w, xst.screenID) END FINALLY Exit(trsl) END END ELSE CreateXWindow(trsl, v, NIL, iconic := TRUE) END; EXCEPT X.Error => RAISE TrestleComm.Failure END; END Iconize; CONST StandardInputMask = X.KeyPressMask + X.KeyReleaseMask + X.ButtonPressMask + X.ButtonReleaseMask + X.EnterWindowMask + X.LeaveWindowMask + X.ExposureMask + X.StructureNotifyMask + X.FocusChangeMask + X.OwnerGrabButtonMask + X.VisibilityChangeMask; <* UNUSED *> CONST MotionHintMask = StandardInputMask + X.PointerMotionMask + X.PointerMotionHintMask; VAR MyHostName: X.XTextProperty; brokenOpenWin := FALSE; CONST TrestleCopArray = ARRAY [0 .. 9] OF CHAR{ 'T', 'r', 'e', 's', 't', 'l', 'e', 'C', 'o', 'p'}; TrestleArray = ARRAY [0 .. 11] OF CHAR{'T', 'r', 'e', 's', 't', 'l', 'e', 'C', 'h', 'i', 'l', 'd'}; PROCEDURECreateXWindow (trsl : T; v : VBT.T; st : XScreenType.T; x, y := 50; iconic, userPosition := FALSE; prop, type := X.None; len, format := 0; addr: Ctypes.unsigned_char_star := NIL) RAISES {TrestleComm.Failure} = VAR cs : ScrnCursor.T; width, height: CARDINAL; ur : Child := v.upRef; xwa : X.XSetWindowAttributes; xhints : X.XWMHints; xSizeHints : X.XSizeHints; atm : ARRAY [0 .. 4] OF X.Atom; cmid : X.Colormap; dec : Decoration := VBT.GetProp(v, TYPECODE(Decoration)); serial: Ctypes.unsigned_long; bstore := X.NotUseful; owns : XClientF.OwnsArray := NIL; nsp: XClientF.NewScreenProp := VBT.GetProp( v, TYPECODE(XClientF.NewScreenProp)); app := TrestleImpl.ChildApp(v); firstAttach := FALSE; BEGIN IF app # NIL THEN firstAttach := (app.primary = trsl.conf) AND trsl.confEnabled END; TRY IF nsp # NIL THEN VBT.RemProp(v, TYPECODE(XClientF.NewScreenProp)); prop := nsp.prop; type := nsp.type; len := nsp.len; format := nsp.format; addr := LOOPHOLE(ADR(nsp.data^[0]), Ctypes.unsigned_char_star); END; Enter(trsl); TRY IF v.st # NIL THEN owns := ur.owns; FOR s := FIRST(owns^) TO LAST(owns^) DO IF trsl.sel[s].v = v THEN trsl.sel[s].v := NIL END END; ur.owns := NEW(XClientF.OwnsArray, 0); X.XDestroyWindow(trsl.dpy, ur.w); ur.w := X.None; END; IF st = NIL THEN st := trsl.screens[trsl.defaultScreen] END; atm[0] := trsl.takeFocus; atm[1] := trsl.deleteWindow; atm[2] := trsl.paNewScreen; atm[3] := trsl.paNewDisplay; atm[4] := trsl.paAddDisplay; bstore := st.backing_store FINALLY Exit(trsl) END; IF st.cmap = NIL THEN cmid := X.CopyFromParent ELSE cmid := XScrnCmap.ColorMapID(st.cmap.standard()); IF cmid = X.None THEN cmid := X.CopyFromParent END END; VBTClass.Rescreen(v, st); width := ROUND(VBT.MMToPixels(v, DefaultWidth, Axis.T.Hor)); height := ROUND(VBT.MMToPixels(v, DefaultHeight, Axis.T.Ver)); VAR s := VBTClass.GetShapes(v); sh := s[Axis.T.Hor]; sv := s[Axis.T.Ver]; BEGIN ur.sh := sh; ur.sv := sv; SetSizeHints(xSizeHints, width, height, sh, sv, st); END; xwa.border_pixel := 0; xwa.bit_gravity := X.NorthWestGravity; xwa.event_mask := StandardInputMask; xwa.colormap := cmid; IF dec = NIL THEN xwa.override_redirect := X.True; xwa.save_under := X.True; xwa.backing_store := X.NotUseful ELSE xwa.override_redirect := X.False; xwa.save_under := X.False; xwa.backing_store := bstore END; xhints.input := X.False; IF iconic THEN xhints.initial_state := X.IconicState ELSE xhints.initial_state := X.NormalState END; xhints.flags := X.InputHint + X.StateHint; LOCK v DO cs := v.getcursor(); Enter(trsl); TRY IF cs = ScrnCursor.DontCare THEN ur.csid := X.None ELSE ur.csid := cs.id END; ur.userPosition := userPosition; ur.w := X.XCreateWindow( trsl.dpy, st.root, x := x, y := y, width := width, height := height, border := 0, depth := st.depth, class := X.InputOutput, visual := st.visual, valuemask := X.CWBorderPixel + X.CWBitGravity + X.CWEventMask + X.CWColormap + X.CWOverrideRedirect + X.CWSaveUnder + X.CWBackingStore, attributes := ADR(xwa)); X.XDefineCursor(trsl.dpy, ur.w, ur.csid); IF firstAttach THEN XProperties.PutProp(trsl, ur.w, ToAtom(trsl, "XMUX_AGENT"), Xatom.XA_STRING, TrestleCopArray, 8) ELSE XProperties.PutProp(trsl, ur.w, ToAtom(trsl, "XMUX_AGENT"), Xatom.XA_STRING, TrestleArray, 8) END; X.XSetWMClientMachine(trsl.dpy, ur.w, ADR(MyHostName)); IF brokenOpenWin THEN VAR min, max: Ctypes.int; BEGIN X.XDisplayKeycodes( trsl.dpy, LOOPHOLE(ADR(min), Ctypes.int_star), LOOPHOLE(ADR(max), Ctypes.int_star)); FOR i := min TO max DO X.XGrabKey(trsl.dpy, i, X.AnyModifier, ur.w, X.True, X.GrabModeAsync, X.GrabModeAsync) END END ELSE X.XGrabKey(trsl.dpy, X.AnyKey, X.AnyModifier, ur.w, X.True, X.GrabModeAsync, X.GrabModeAsync); END; FOR i := FIRST(trsl.ungrab) TO LAST(trsl.ungrab) DO WITH cd = trsl.ungrab[i] DO IF cd # 0 THEN X.XUngrabKey(trsl.dpy, cd, X.AnyModifier, ur.w) END END END; IF prop # X.None THEN X.XChangeProperty(trsl.dpy, ur.w, prop, type, format, X.PropModeReplace, addr, len); IF nsp # NIL THEN DISPOSE(nsp.data) END END; xwa.event_mask := X.PropertyChangeMask; ur.xcage := X.XCreateWindow( trsl.dpy, ur.w, x := -1, y := -1, width := 1, height := 1, border := 0, depth := 0, class := X.InputOnly, visual := LOOPHOLE(X.CopyFromParent, X.VisualStar), valuemask := X.CWEventMask, attributes := ADR(xwa)); ur.cageRect := Rect.FromEdges(-1, 0, -1, 0); ur.width := width; ur.height := height; EVAL trsl.vbts.put(ur.w, v); X.XMapSubwindows(trsl.dpy, ur.w); ur.decorated := dec # NIL; IF dec # NIL THEN SetDecoration(trsl, ur.w, NIL, dec); X.XSetWMHints(trsl.dpy, ur.w, ADR(xhints)); X.XSetWMNormalHints(trsl.dpy, ur.w, ADR(xSizeHints)); EVAL X.XSetWMProtocols(trsl.dpy, ur.w, ADR(atm[0]), NUMBER(atm)); END; serial := X.XNextRequest(trsl.dpy); IF dec # NIL OR NOT iconic THEN X.XMapWindow(trsl.dpy, ur.w) END; IF dec = NIL AND NOT iconic THEN VAR ev: X.XEvent; e := LOOPHOLE(ADR(ev), X.XMapEventStar); BEGIN e.type := X.MapNotify; e.serial := serial; e.send_event := X.False; e.display := trsl.dpy; e.event := ur.w; e.window := ur.w; e.override_redirect := X.True; XClientF.BackDoor(trsl, ev) END END FINALLY Exit(trsl) END END; IF owns # NIL THEN FOR i := FIRST(owns^) TO LAST(owns^) DO IF owns[i] THEN VBTClass.Misc(v, VBT.MiscRec{VBT.Lost, VBT.NullDetail, 0, VBT.Selection{i}}) END END END; TrestleImpl.UpdateBuddies(v); EXCEPT X.Error => RAISE TrestleComm.Failure END; END CreateXWindow; PROCEDURECreateXPixmap (trsl : T; v : VBT.T; st : XScreenType.T; width, height: CARDINAL ) RAISES {TrestleComm.Failure} = VAR ur: Child := v.upRef; BEGIN TRY VBTClass.Rescreen(v, st); LOCK v DO Enter(trsl); TRY ur.w := X.XCreatePixmap(trsl.dpy, st.root, width := width, height := height, depth := st.depth); ur.xcage := X.None; ur.cageRect := Rect.Full; ur.width := width; ur.height := height; EVAL trsl.vbts.put(ur.w, v); ur.reshapeComing := FALSE; ur.mapped := TRUE FINALLY Exit(trsl) END END; VBTClass.Reshape(v, Rect.FromSize(width, height), Rect.Empty); EXCEPT X.Error => RAISE TrestleComm.Failure END; END CreateXPixmap; PROCEDURESetColorMap (trsl: T; v: VBT.T; cm: ScrnColorMap.T) RAISES {} = VAR xid := XScrnCmap.ColorMapID(cm); ur : Child := v.upRef; BEGIN TRY Enter(trsl); TRY X.XSetWindowColormap(trsl.dpy, ur.w, xid) FINALLY Exit(trsl) END EXCEPT X.Error, TrestleComm.Failure => (* skip *) END END SetColorMap; PROCEDURETickTime (<*UNUSED*> trsl: T): INTEGER = BEGIN RETURN 1000 END TickTime; PROCEDUREAllCeded (trsl: T): BOOLEAN RAISES {} = BEGIN TRY Enter(trsl); TRY X.XSync(trsl.dpy, X.False); RETURN XEventQueue.IsEmpty(trsl.evq) AND (X.XEventsQueued(trsl.dpy, X.QueuedAfterReading) = 0) FINALLY Exit(trsl) END EXCEPT X.Error, TrestleComm.Failure => RETURN FALSE END END AllCeded; PROCEDUREGetScreens (trsl: T): Trestle.ScreenArray RAISES {} = VAR res: Trestle.ScreenArray; BEGIN LOCK trsl DO res := NEW(Trestle.ScreenArray, NUMBER(trsl.screens^)); FOR i := 0 TO LAST(res^) DO res[i].id := i; res[i].dom := trsl.screens[i].rootDom; res[i].delta := Point.Origin; res[i].type := trsl.screens[i] END END; RETURN res END GetScreens; PROCEDURESetDecoration (trsl: T; w: X.Window; old, new: Decoration) RAISES {TrestleComm.Failure} = (* The decorations for w have changed from old to new; this procedure relays this change to the X window manager. LL = trsl. *) VAR xClassHint: X.XClassHint; BEGIN TRY IF new = NIL OR w = X.None THEN RETURN END; IF (old = NIL) OR NOT Text.Equal(old.windowTitle, new.windowTitle) THEN WITH s = M3toC.SharedTtoS(new.windowTitle) DO TRY X.XStoreName(trsl.dpy, w, s); FINALLY M3toC.FreeSharedS(new.windowTitle, s); END; END END; IF (old = NIL) OR NOT Text.Equal(old.iconTitle, new.iconTitle) THEN WITH s = M3toC.SharedTtoS(new.iconTitle) DO TRY X.XSetIconName(trsl.dpy, w, s); FINALLY M3toC.FreeSharedS(new.iconTitle, s); END; END END; IF (old = NIL) OR NOT Text.Equal(old.inst, new.inst) OR NOT Text.Equal(old.applName, new.applName) THEN TRY xClassHint.res_name := M3toC.SharedTtoS(new.inst); xClassHint.res_class := M3toC.SharedTtoS(new.applName); X.XSetClassHint(trsl.dpy, w, ADR(xClassHint)); X.XSetCommand(trsl.dpy, w, LOOPHOLE(ADR(xClassHint.res_class), X.Argv), 1); FINALLY M3toC.FreeSharedS(new.inst, xClassHint.res_name); M3toC.FreeSharedS(new.applName, xClassHint.res_class); END; END; EXCEPT X.Error => RAISE TrestleComm.Failure END; END SetDecoration; PROCEDUREDecorate (trsl: T; v: VBT.T; old, new: Decoration) RAISES {TrestleComm.Failure} = BEGIN TYPECASE v.upRef OF NULL => (*skip*) | Child (ch) => Enter(trsl); TRY SetDecoration(trsl, ch.w, old, new) FINALLY Exit(trsl) END ELSE (* skip*) END END Decorate; PROCEDUREMoveResize ( dpy : X.DisplayStar; w : X.Window; READONLY r, s: Rect.T ) RAISES {TrestleComm.Failure} = BEGIN TRY IF NOT Rect.Equal(r, s) THEN X.XMoveResizeWindow( dpy, w, r.west, r.north, r.east - r.west, r.south - r.north) END; EXCEPT X.Error => RAISE TrestleComm.Failure END; END MoveResize; CONST LargeRect = Rect.T{0, 10000, 0, 10000}; SmallRect = Rect.T{-1, 0, -1, 0}; PROCEDURESetCage (v: T; ch: VBT.T) RAISES {} = VAR ur : Child := ch.upRef; dpy : X.DisplayStar; xcage: X.Window; newCg: Rect.T; BEGIN WITH cage = VBTClass.Cage(ch) DO IF ch.st = NIL OR ur = NIL OR ch.parent # v THEN IF NOT (TRUE IN cage.inOut) THEN VBTClass.ForceEscape(ch) END; RETURN END; TRY Enter(v); TRY IF ur.cageCovered THEN RETURN END; dpy := v.dpy; xcage := ur.xcage; IF ur.inside THEN IF NOT (FALSE IN cage.inOut) THEN newCg := SmallRect ELSE newCg := Rect.Meet(LargeRect, cage.rect); IF Rect.IsEmpty(newCg) THEN newCg := SmallRect END END; MoveResize(dpy, xcage, LargeRect, ur.cageRect); MoveResize(dpy, xcage, newCg, LargeRect); ur.cageRect := newCg ELSE MoveResize(dpy, xcage, SmallRect, ur.cageRect); ur.cageRect := SmallRect; IF NOT (TRUE IN cage.inOut) THEN VBTClass.ForceEscape(ch) END END FINALLY Exit(v) END EXCEPT TrestleComm.Failure => (* skip *) END END END SetCage; PROCEDURESync (v: T; ch: VBT.T; wait := TRUE) RAISES {} = VAR ur : Child := ch.upRef; data: INTEGER; wf := NEW(XProperties.PropertyWaitFor); win := ur.xcage; BEGIN IF ch.st = NIL THEN RETURN END; TRY Enter(v); TRY Thread.Release(ch); IF NOT wait THEN X.XFlush(v.dpy); ELSE IF win = X.None THEN X.XSync(v.dpy, X.False) ELSE wf.types[0] := 0; wf.types[1] := X.PropertyNotify; wf.d := win; wf.reqno := X.XNextRequest(v.dpy); wf.a := v.miscAtom; wf.ts := 0; X.XChangeProperty(v.dpy, win, v.miscAtom, v.miscAtom, 32, X.PropModeAppend, LOOPHOLE(ADR(data), Ctypes.const_unsigned_char_star), 0); IF XClientF.Await(v, wf, 10) # X.PropertyNotify AND NOT v.dead THEN X.XSync(v.dpy, X.False) END END END FINALLY Exit(v); Thread.Acquire(ch); END EXCEPT X.Error, TrestleComm.Failure => (* skip *) END END Sync; PROCEDURESetCursor (v: T; ch: VBT.T) RAISES {} = VAR ur : Child := ch.upRef; csid: X.Cursor; BEGIN IF ch.st = NIL OR ur.w = X.None THEN RETURN END; WITH cs = ch.getcursor() DO TRY Enter(v); TRY IF cs = ScrnCursor.DontCare THEN csid := X.None ELSE csid := cs.id END; IF ur.csid # csid THEN ur.csid := csid; X.XDefineCursor(v.dpy, ur.w, csid) END FINALLY Exit(v) END EXCEPT X.Error, TrestleComm.Failure => (* skip *) END END END SetCursor; PROCEDURETypeCodeToXType (v: T; tc: INTEGER): X.Atom RAISES {TrestleComm.Failure} = BEGIN IF tc = -1 OR tc = TYPECODE(TEXT) THEN RETURN ToAtom(v, "STRING") ELSE RETURN X.None END END TypeCodeToXType; PROCEDURESelectionAtom (v: T; s: VBT.Selection): X.Atom RAISES {TrestleComm.Failure} = <* LL.sup = v *> VAR name := v.sel[s.sel].name; BEGIN IF name = X.None THEN WITH txt = VBT.SelectionName(s) DO IF txt # NIL THEN name := ToAtom(v, txt); v.sel[s.sel].name := name END END END; RETURN name END SelectionAtom; PROCEDUREWriteUp ( v : T; ch : VBT.T; <*UNUSED*> w : VBT.T; s : VBT.Selection; ts : VBT.TimeStamp; val: VBT.Value; tc : CARDINAL ) RAISES {VBT.Error} = VAR sc : VBT.T := NIL; multi : ARRAY [0 .. 3] OF Ctypes.int; buf : UNTRACED REF ARRAY OF CHAR; error := FALSE; ec : VBT.ErrorCode; vl : REFANY; name, type, mulsym: X.Atom; ur : Child; BEGIN TRY LOCK v DO XProperties.ExtendSel(v.sel, s); IF v.sel[s.sel].v # NIL THEN sc := v.sel[s.sel].v END END; IF sc # NIL THEN sc.write(s, val, tc) ELSE vl := val.toRef(); Enter(v); TRY name := SelectionAtom(v, s); ur := ch.upRef; type := TypeCodeToXType(v, tc); IF name = X.None THEN RAISE VBT.Error(VBT.ErrorCode.Unwritable) ELSIF ur.xcage = X.None THEN RAISE VBT.Error(VBT.ErrorCode.Uninstalled) ELSIF vl # NIL AND TYPECODE(vl) # tc OR type = X.None THEN RAISE VBT.Error(VBT.ErrorCode.WrongType) END; mulsym := XClientF.NewAtom(v); multi[0] := ToAtom(v, "DELETE"); multi[1] := XClientF.NewAtom(v); multi[2] := ToAtom(v, "INSERT_PROPERTY"); multi[3] := XClientF.NewAtom(v); XProperties.PutProp(v, ur.xcage, mulsym, ToAtom(v, "ATOM_PAIR"), LOOPHOLE(multi, ARRAY [0 .. 15] OF CHAR), 32); IF vl # NIL AND tc = TYPECODE(TEXT) THEN buf := NEW(UNTRACED REF ARRAY OF CHAR, Text.Length(vl)); IF Text.Length(vl) > 0 THEN Text.SetChars(buf^, vl) END; XProperties.PutProp(v, ur.xcage, multi[3], type, buf^, 8); DISPOSE(buf); ELSE RAISE VBT.Error(VBT.ErrorCode.WrongType) END; TRY EVAL XProperties.AwaitConversion( v, ur.xcage, name, ToAtom(v, "MULTIPLE"), mulsym, ts, 20) EXCEPT VBT.Error (err) => error := TRUE; IF err = VBT.ErrorCode.Unreadable THEN ec := VBT.ErrorCode.Unwritable ELSE ec := err END END; IF NOT error OR ec # VBT.ErrorCode.TimeOut THEN XClientF.FreeAtom(v, mulsym); VAR atm: X.Atom; BEGIN atm := multi[1]; XClientF.FreeAtom(v, atm); multi[1] := atm; atm := multi[3]; XClientF.FreeAtom(v, atm); multi[3] := atm END; END; IF error THEN RAISE VBT.Error(ec) END FINALLY Exit(v) END END EXCEPT TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END END WriteUp; PROCEDUREReadUp ( v : T; ch: VBT.T; <*UNUSED*> w : VBT.T; s : VBT.Selection; ts: VBT.TimeStamp; tc: CARDINAL ): VBT.Value RAISES {VBT.Error} = VAR sc : VBT.T := NIL; res: REFANY; BEGIN TRY Enter(v); TRY XProperties.ExtendSel(v.sel, s); IF v.sel[s.sel].v # NIL THEN sc := v.sel[s.sel].v ELSE VAR name := SelectionAtom(v, s); ur : Child := ch.upRef; type := TypeCodeToXType(v, tc); sym, rsym: X.Atom; BEGIN IF name = X.None THEN RAISE VBT.Error(VBT.ErrorCode.Unreadable) ELSIF ur.xcage = X.None THEN RAISE VBT.Error(VBT.ErrorCode.Uninstalled) ELSIF type = X.None THEN RAISE VBT.Error(VBT.ErrorCode.WrongType) END; sym := XClientF.NewAtom(v); TRY rsym := XProperties.AwaitConversion( v, ur.xcage, name, type, sym, ts); IF rsym # sym THEN XClientF.FreeAtom(v, sym) END; res := XProperties.ReadXSelFromProp(v, ur.xcage, rsym, type); XClientF.FreeAtom(v, sym); EXCEPT VBT.Error (ec) => IF ec # VBT.ErrorCode.TimeOut THEN XClientF.FreeAtom(v, sym) END; RAISE VBT.Error(ec) END END END FINALLY Exit(v) END; IF sc # NIL THEN RETURN sc.read(s, tc) ELSE RETURN VBT.FromRef(res) END EXCEPT TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END END ReadUp; PROCEDURESetSizeHints (VAR xhints : X.XSizeHints; VAR width, height: CARDINAL; READONLY sh, sv : VBT.SizeRange; st : XScreenType.T ) = BEGIN IF sv.hi < VBT.DefaultShape.hi OR sh.hi < VBT.DefaultShape.hi THEN xhints.flags := X.PMinSize + X.PMaxSize + X.PResizeInc + X.PBaseSize ELSE xhints.flags := X.PMinSize + X.PResizeInc + X.PBaseSize END; xhints.base_width := 0; xhints.base_height := 0; xhints.width_inc := 1; xhints.height_inc := 1; xhints.min_width := sh.lo; xhints.max_width := MAX(MIN(sh.hi - 1, Rect.HorSize(st.rootDom)), sh.lo); xhints.min_height := sv.lo; xhints.max_height := MAX(MIN(sv.hi - 1, Rect.VerSize(st.rootDom)), sv.lo); IF sh.pref # 0 THEN width := MIN(sh.pref, xhints.max_width) ELSIF (sh.hi > 1) AND (sh.hi <= width) THEN width := xhints.max_width END; IF sv.pref # 0 THEN height := MIN(sv.pref, xhints.max_height) ELSIF (sv.hi > 1) AND (sv.hi <= height) THEN height := xhints.max_height END; END SetSizeHints; PROCEDURESetXShape (v: T; ch: VBT.T) = (* LL = VBT.mu *) VAR xhints : X.XSizeHints; seqno : Ctypes.unsigned_long; mustReshape := FALSE; width, height: CARDINAL := 0; ur : Child := ch.upRef; wf := NEW(MessageWaitFor); st : XScreenType.T := ch.st; s := VBTClass.GetShapes(ch); sh := s[Axis.T.Hor]; sv := s[Axis.T.Ver]; BEGIN SetSizeHints(xhints, width, height, sh, sv, st); TRY Enter(v); TRY IF sh = ur.sh AND sv = ur.sv THEN RETURN END; ur.sh := sh; ur.sv := sv; X.XSetWMNormalHints(v.dpy, ur.w, ADR(xhints)); IF ((width # ur.width) OR (height # ur.height)) AND (width # 0) AND (height # 0) THEN seqno := X.XNextRequest(v.dpy); X.XResizeWindow(v.dpy, ur.w, width, height); IF ur.mapped THEN wf.types[0] := X.ConfigureNotify; wf.types[1] := X.UnmapNotify; wf.types[2] := 0; wf.types[3] := X.ClientMessage; wf.atm := ToAtom(v, "WM_CONFIGURE_DENIED"); wf.d := ur.w; wf.reqno := seqno; WITH type = XClientF.Await(v, wf, 2) DO IF type > 1 AND type # X.ClientMessage THEN mustReshape := TRUE; XClientF.GetDomain(ur, width, height) END END END END FINALLY Exit(v); IF mustReshape THEN XClientF.Reshape(ch, width, height) END END EXCEPT X.Error, TrestleComm.Failure => (* skip *) END END SetXShape; TYPE MessageWaitFor = SimpleWaitFor OBJECT atm: X.Atom OVERRIDES match := MessageMatch END; PROCEDUREMessageMatch (wf: MessageWaitFor; READONLY ev: X.XEvent): BOOLEAN = BEGIN IF NOT SimpleWaitFor.match(wf, ev) THEN RETURN FALSE END; WITH e = LOOPHOLE(ADR(ev), X.XAnyEventStar), type = e.type DO IF type # X.ClientMessage THEN RETURN TRUE END; WITH cm = LOOPHOLE(e, X.XClientMessageEventStar) DO RETURN cm.message_type = wf.atm END END END MessageMatch; PROCEDURENewShape (v: T; ch: VBT.T) RAISES {} = BEGIN IF ch.st = NIL THEN RETURN END; VBT.Mark(v) END NewShape; PROCEDURERedisplay (v: T) = <*FATAL Split.NotAChild*> VAR ch := Split.Succ(v, NIL); BEGIN WHILE ch # NIL DO IF VBTClass.HasNewShape(ch) AND ch.st # NIL THEN SetXShape(v, ch) END; ch := Split.Succ(v, ch) END END Redisplay; PROCEDUREToName (trsl: T; a: X.Atom): TEXT RAISES {TrestleComm.Failure} = VAR name: TEXT; BEGIN TRY IF trsl.atoms.get(a, name) THEN RETURN name ELSE VAR cname := X.XGetAtomName(trsl.dpy, a); name : TEXT; BEGIN IF cname = NIL THEN name := "Unknown atom 0" & Fmt.Unsigned(a) & "H" ELSE name := M3toC.CopyStoT(cname); X.XFree(cname) END; EVAL trsl.atoms.put(a, name); EVAL trsl.names.put(name, a); RETURN name END END; EXCEPT X.Error => RAISE TrestleComm.Failure END; END ToName; PROCEDUREToAtom (trsl: T; name: TEXT): X.Atom RAISES {TrestleComm.Failure} = VAR a: X.Atom; BEGIN TRY IF trsl.names.get(name, a) THEN RETURN a ELSE VAR s := M3toC.SharedTtoS(name); a: X.Atom; BEGIN TRY a := X.XInternAtom(trsl.dpy, s, X.False); EVAL trsl.atoms.put(a, name); EVAL trsl.names.put(name, a); FINALLY M3toC.FreeSharedS(name, s); END; RETURN a END END; EXCEPT X.Error => RAISE TrestleComm.Failure END; END ToAtom; PROCEDUREAcquire ( v : T; chVBT: VBT.T; <*UNUSED*> w : VBT.T; s : VBT.Selection; ts : VBT.TimeStamp ) RAISES {VBT.Error} = VAR ch : Child; focus : X.Window; revert: Ctypes.int; BEGIN TRY Enter(v); TRY ch := chVBT.upRef; IF ch = NIL OR ch.xcage = X.None THEN RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END; XProperties.ExtendOwns(ch.owns, s); XProperties.ExtendSel(v.sel, s); IF s = VBT.KBFocus THEN IF NOT (ch.isXFocus OR ch.inside AND ch.underXFocus) THEN X.XSetInputFocus(v.dpy, ch.w, X.RevertToParent, ts); X.XGetInputFocus(v.dpy, ADR(focus), ADR(revert)); IF focus # ch.w THEN RAISE VBT.Error(VBT.ErrorCode.EventNotCurrent) END; ch.isXFocus := TRUE; ch.underXFocus := TRUE ELSIF ch.isXFocus THEN X.XSetInputFocus(v.dpy, ch.w, X.RevertToParent, ts) END; ch.owns[s.sel] := TRUE; v.sel[s.sel].v := chVBT; v.sel[s.sel].ts := ts ELSE X.XSetSelectionOwner(v.dpy, SelectionAtom(v, s), ch.w, ts); IF ch.w = X.XGetSelectionOwner(v.dpy, v.sel[s.sel].name) THEN ch.owns[s.sel] := TRUE; IF v.sel[s.sel].v # NIL THEN VAR ev: X.XEvent; ur: Child := v.sel[s.sel].v.upRef; BEGIN WITH e = LOOPHOLE(ADR(ev), X.XSelectionClearEventStar) DO e.type := X.SelectionClear; e.send_event := X.False; e.display := v.dpy; e.window := ur.w; e.selection := v.sel[s.sel].name; e.time := 0; END; XClientF.BackDoor(v, ev) END END; v.sel[s.sel].v := chVBT; v.sel[s.sel].ts := ts ELSE RAISE VBT.Error(VBT.ErrorCode.EventNotCurrent) END END FINALLY Exit(v) END EXCEPT X.Error, TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END END Acquire; PROCEDURERelease ( v : T; chVBT: VBT.T; <*UNUSED*> w : VBT.T; s : VBT.Selection) RAISES {} = VAR ch: Child; BEGIN TRY Enter(v); TRY ch := chVBT.upRef; XProperties.ExtendOwns(ch.owns, s); XProperties.ExtendSel(v.sel, s); IF v.sel[s.sel].v = chVBT THEN IF s = VBT.KBFocus THEN IF ch.isXFocus THEN X.XSetInputFocus( v.dpy, X.PointerRoot, X.RevertToParent, v.sel[s.sel].ts) END ELSE X.XSetSelectionOwner( v.dpy, SelectionAtom(v, s), X.None, v.sel[s.sel].ts) END; v.sel[s.sel].v := NIL END FINALLY Exit(v) END EXCEPT X.Error, TrestleComm.Failure => (* skip *) END END Release; PROCEDUREForge ( v : T; chVBT : VBT.T; <*UNUSED*> w : VBT.T; <*UNUSED*> type : VBT.MiscCodeType; <*UNUSED*> READONLY detail: ARRAY [0 .. 1] OF INTEGER) RAISES {VBT.Error} = VAR ch: Child := chVBT.upRef; BEGIN TRY Enter(v); TRY IF ch = NIL OR ch.xcage = X.None THEN RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END; EVAL Thread.Fork(NEW(ForgeClosure, v := v, chVBT := chVBT, win := ch.xcage, stackSize := 20000)); FINALLY Exit(v) END EXCEPT TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END END Forge; PROCEDUREDoForge (self: ForgeClosure): REFANY RAISES {} = VAR data: INTEGER; wf := NEW(XProperties.PropertyWaitFor); BEGIN TRY Enter(self.v); TRY wf.types[0] := 0; wf.types[1] := X.PropertyNotify; wf.d := self.win; wf.reqno := X.XNextRequest(self.v.dpy); wf.a := self.v.miscAtom; wf.ts := 0; X.XChangeProperty( self.v.dpy, self.win, self.v.miscAtom, self.v.miscAtom, 32, X.PropModeAppend, LOOPHOLE(ADR(data), Ctypes.unsigned_char_star) , 0); EVAL XClientF.Await(self.v, wf, 5); FINALLY Exit(self.v) END EXCEPT X.Error, TrestleComm.Failure => wf.ts := 0 END; LOCK VBT.mu DO VBTClass.Misc( self.chVBT, VBT.MiscRec{VBT.TrestleInternal, VBT.NullDetail, wf.ts, VBT.Forgery}) END; RETURN NIL END DoForge; TYPE ForgeClosure = Thread.SizedClosure OBJECT v : T; chVBT: VBT.T; win : X.Window OVERRIDES apply := DoForge END; PROCEDUREPut ( v : T; chVBT : VBT.T; <*UNUSED*> w : VBT.T; s : VBT.Selection; ts : VBT.TimeStamp; type : VBT.MiscCodeType; READONLY detail: ARRAY [0 .. 1] OF INTEGER) RAISES {VBT.Error} = VAR ch : Child := chVBT.upRef; win: X.Window; ev : X.XClientMessageEvent_l; BEGIN TRY Enter(v); TRY IF ch = NIL OR ch.xcage = X.None THEN RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END; XProperties.ExtendSel(v.sel, s); IF s = VBT.KBFocus THEN win := X.InputFocus ELSE win := X.XGetSelectionOwner(v.dpy, SelectionAtom(v, s)) END; IF win = X.None THEN RAISE VBT.Error(VBT.ErrorCode.UnownedSelection) END; ev.type := X.ClientMessage; ev.window := win; ev.message_type := v.miscAtom; ev.format := 32; WITH data = ev.data DO data[0] := ToAtom(v, VBT.MiscCodeTypeName(type)); data[1] := ts; data[2] := ToAtom(v, VBT.SelectionName(s)); data[3] := detail[0]; data[4] := detail[1] END; EVAL X.XSendEvent(v.dpy, win, X.False, 0, LOOPHOLE(ADR(ev), X.XEventStar)); FINALLY Exit(v) END EXCEPT X.Error, TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled) END END Put; VAR namebuf: ARRAY [0 .. 255] OF Ctypes.char; PROCEDUREInit () = BEGIN EVAL Unix.gethostname(ADR(namebuf[0]), NUMBER(namebuf)); MyHostName := X.XTextProperty{LOOPHOLE(ADR(namebuf[0]), Ctypes.unsigned_char_star), Xatom.XA_STRING, 8, Cstring.strlen(ADR(namebuf[0])) + 1}; TrestleClass.RegisterConnectClosure( NEW(TrestleClass.ConnectClosure, apply := DoConnect)) END Init; PROCEDUREDoConnect (self : TrestleClass.ConnectClosure; inst : TEXT; localOnly: BOOLEAN; VAR (*OUT*) t : Trestle.T): BOOLEAN = VAR res := XClientF.DoConnect (self, inst, localOnly, t); xt : T := t; cp : Ctypes.char_star; txt : TEXT; BEGIN IF (xt # NIL) AND NOT brokenOpenWin THEN cp := X.XServerVendor (xt.dpy); IF (cp # NIL) THEN txt := M3toC.StoT (cp); IF Text.Equal (Text.Sub (txt, 0, 10), "X11/NeWS -") THEN brokenOpenWin := TRUE; END; END; END; RETURN res; END DoConnect; EXCEPTION FatalError; PROCEDURECrash () = <* FATAL FatalError *> BEGIN RAISE FatalError END Crash; BEGIN END XClient.