(* Copyright C) 1992, Digital Equipment Corporation *)
(* All rights reserved. *)
(* See the file COPYRIGHT for a full description. *)
(* *)
(* by Steve Glassman, Mark Manasse and Greg Nelson *)
(* Last modified on Mon Dec 14 10:34:11 PST 1992 by msm *)
(* modified on Fri Jul 31 23:40:42 1992 by steveg *)

(* modified on Mon Feb 24 13:59:43 PST 1992 by muller *)
(* modified on Sat Jan 11 19:03:47 PST 1992 by gnelson*)


<*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 XClient;

IMPORT X, VBT, TrestleClass, TrestleComm, Ctypes, M3toC, XEventQueue,
       XScreenType, Point, Rect, ProperSplit, Trestle, Thread, VBTClass,
       Axis, Text, Split, ScrnCursor, IntegerToTextTable, ScrnColorMap,
       TextToIntegerTable, VBTRep, XClientF, XPaint, TrestleImpl, Char,
       XProperties, TrestleOnX, XScrnCmap, Cstring, Unix, Xatom, Fmt;

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;
        updateBuddies    := UpdateBuddies;
      END;

PROCEDURE TrestleID(t: T): TEXT =
  BEGIN
    RETURN t.inst
  END TrestleID;

PROCEDURE WindowID(<* UNUSED *>t: T; v: VBT.T): TEXT =
  BEGIN
    RETURN Fmt.Unsigned(TrestleOnX.Drawable(v), base := 10)
  END WindowID;

PROCEDURE UpdateBuddies (t: T; v: VBT.T; 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 := Text.Cat(trslProp, trsls[LAST(trsls)])
          END;
          tp := NEW(REF ARRAY OF CHAR, Text.Length(trslProp) + 1);
          Text.SetChars(tp^, trslProp);
          tp[LAST(tp^)] := Char.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^)] := Char.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 *> PROCEDURE Outside (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;

PROCEDURE BeChild (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;

PROCEDURE Replace (trsl: T; ch, new: VBT.T) RAISES {} =
  VAR ur: Child := ch.upRef;
  BEGIN
    IF new # NIL THEN RAISE FatalError END;
    TRY
      Enter(trsl);
      TRY
        IF ur.xcage = X.None THEN
          X.XFreePixmap(trsl.dpy, ur.w)
        ELSE
          X.XDestroyWindow(trsl.dpy, ur.w)
        END
      FINALLY
        Exit(trsl)
      END
    EXCEPT
      TrestleComm.Failure =>    (* skip *)
    END;
    XClientF.Delete(trsl, ch, ur)
  END Replace;

PROCEDURE Attach (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 *)

EXCEPTION FatalError;           <* FATAL FatalError *>

PROCEDURE MoveNear (trsl: T; v, w: VBT.T) RAISES {TrestleComm.Failure} =
  VAR
    st: XScreenType.T;
    nw                := Point.T{50, 50};
    ch: Child;
  BEGIN
    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
      LOCK trsl DO st := trsl.screens[trsl.defaultScreen] END
    ELSE
      st := w.st;
      Enter(trsl);
      TRY
        XClientF.ValidateNW(trsl, ch, st);
        nw := Point.Add(nw, ch.nw)
      FINALLY
        Exit(trsl)
      END
    END;
    InnerOverlap(trsl, v, st.screenID, nw, w # NIL)
  END MoveNear;

PROCEDURE InstallOffscreen (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;

PROCEDURE MatchScreenType (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;

PROCEDURE ScreenOf (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;

PROCEDURE Overlap (         trsl: T;
                            v   : VBT.T;
                            id  : Trestle.ScreenID;
                   READONLY nw  : Point.T           )
  RAISES {TrestleComm.Failure} =
  BEGIN
    InnerOverlap(trsl, v, id, nw, TRUE)
  END Overlap;

PROCEDURE InnerOverlap (         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.char_star := NIL     )
  RAISES {TrestleComm.Failure} =
  VAR
    st           : XScreenType.T;
    alreadyMapped: BOOLEAN;
  BEGIN
    LOCK trsl DO
      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;
    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 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
  END InnerOverlap;

PROCEDURE Iconize (trsl: T; v: VBT.T) RAISES {TrestleComm.Failure} =
  VAR alreadyMapped: BOOLEAN;
  BEGIN
    alreadyMapped := v.st # NIL;
    IF alreadyMapped THEN
      VAR
        xst: XScreenType.T := v.st;
        ur : Child         := v.upRef;
      BEGIN
        Enter(trsl);
        TRY
          EVAL X.XIconifyWindow(trsl.dpy, ur.w, xst.screenID)
        FINALLY
          Exit(trsl)
        END
      END
    ELSE
      CreateXWindow(trsl, v, NIL, iconic := TRUE)
    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;

<* UNUSED *> CONST
  MotionHintMask = StandardInputMask + X.PointerMotionMask
                     + X.PointerMotionHintMask;

VAR
  MyHostName: X.XTextProperty;

PROCEDURE CreateXWindow (trsl                : T;
                         v                   : VBT.T;
                         st                  : XScreenType.T;
                         x, y                                   := 50;
                         iconic, userPosition                   := FALSE;
                         prop, type                             := X.None;
                         len, format                            := 0;
                         addr                : Ctypes.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.UnsignedLong;
    owns  : XClientF.OwnsArray  := NIL;
    nsp: XClientF.NewScreenProp := VBT.GetProp(
                                     v, TYPECODE(XClientF.NewScreenProp));
  BEGIN
    IF nsp # NIL THEN
      VBT.RemProp(v, TYPECODE(XClientF.NewScreenProp));
      prop := nsp.prop;
      type := nsp.type;
      len := nsp.len;
      format := nsp.format;
      addr := ADR(nsp.data^[0])
    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
    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));
    WITH s  = VBTClass.GetShapes(v),
         sh = s[Axis.T.Hor],
         sv = s[Axis.T.Ver]          DO
      IF sh.pref # 0 THEN
        width := sh.pref
      ELSIF (sh.hi > 1) AND (sh.hi <= width) THEN
        width := sh.hi - 1
      END;
      xSizeHints.min_width := sh.lo;
      xSizeHints.max_width := sh.hi - 1;
      ur.sh := sh;
      IF sv.pref # 0 THEN
        height := sv.pref
      ELSIF (sv.hi > 1) AND (sv.hi <= height) THEN
        height := sv.hi - 1
      END;
      xSizeHints.min_height := sv.lo;
      xSizeHints.max_height := sv.hi - 1;
      ur.sv := sv;
      IF sv.hi < VBT.DefaultShape.hi OR sh.hi < VBT.DefaultShape.hi THEN
        xSizeHints.flags := X.PMinSize + X.PMaxSize
      ELSE
        xSizeHints.flags := X.PMinSize
      END
    END;
    IF userPosition THEN
      INC(xSizeHints.flags, X.USPosition + X.USSize)
    ELSE
      INC(xSizeHints.flags, X.PPosition + X.PSize)
    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;
    ELSE
      xwa.override_redirect := X.False;
      xwa.save_under := X.False
    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,
            attributes := ADR(xwa));
        X.XDefineCursor(trsl.dpy, ur.w, ur.csid);
        X.XSetWMClientMachine(trsl.dpy, ur.w, ADR(MyHostName));
        X.XGrabKey(trsl.dpy, X.AnyKey, X.AnyModifier, ur.w, X.True,
                   X.GrabModeAsync, X.GrabModeAsync);
        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);
        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);
        X.XMapWindow(trsl.dpy, ur.w);
        IF dec = NIL 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)
  END CreateXWindow;

PROCEDURE CreateXPixmap (trsl         : T;
                         v            : VBT.T;
                         st           : XScreenType.T;
                         width, height: CARDINAL       )
  RAISES {TrestleComm.Failure} =
  VAR ur: Child := v.upRef;
  BEGIN
    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)
  END CreateXPixmap;

PROCEDURE SetColorMap (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
      TrestleComm.Failure =>    (* skip *)
    END
  END SetColorMap;

PROCEDURE TickTime (<*UNUSED*> trsl: T): INTEGER =
  BEGIN
    RETURN 1000
  END TickTime;

PROCEDURE AllCeded (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
      TrestleComm.Failure => RETURN FALSE
    END
  END AllCeded;

PROCEDURE GetScreens (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;

PROCEDURE SetDecoration (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
    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.TtoS(new.windowTitle) DO
        TRY X.XStoreName(trsl.dpy, w, s) FINALLY M3toC.FreeS(s) END
      END
    END;
    IF (old = NIL) OR NOT Text.Equal(old.iconTitle, new.iconTitle) THEN
      WITH s = M3toC.TtoS(new.iconTitle) DO
        TRY X.XSetIconName(trsl.dpy, w, s) FINALLY M3toC.FreeS(s) END
      END
    END;
    IF (old = NIL) OR NOT Text.Equal(old.inst, new.inst)
         OR NOT Text.Equal(old.applName, new.applName) THEN
      xClassHint.res_name := M3toC.TtoS(new.inst);
      xClassHint.res_class := M3toC.TtoS(new.applName);
      TRY
        X.XSetClassHint(trsl.dpy, w, ADR(xClassHint));
        X.XSetCommand(trsl.dpy, w, ADR(xClassHint.res_class), 1)
      FINALLY
        M3toC.FreeS(xClassHint.res_name);
        M3toC.FreeS(xClassHint.res_class)
      END
    END
  END SetDecoration;

PROCEDURE Decorate (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;

PROCEDURE MoveResize (         dpy : X.DisplayStar;
                               w   : X.Window;
                      READONLY r, s: Rect.T         )
  RAISES {TrestleComm.Failure} =
  BEGIN
    IF NOT Rect.Equal(r, s) THEN
      X.XMoveResizeWindow(
        dpy, w, r.west, r.north, r.east - r.west, r.south - r.north)
    END
  END MoveResize;

CONST
  LargeRect = Rect.T{0, 10000, 0, 10000};
  SmallRect = Rect.T{-1, 0, -1, 0};

PROCEDURE SetCage (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 THEN
        IF NOT (TRUE IN cage.inOut) THEN VBTClass.ForceEscape(ch) END;
        RETURN
      END;
      TRY
        Enter(v);
        TRY
          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;

PROCEDURE Sync (v: T; ch: VBT.T) 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 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, ADR(data), 0);
          IF XClientF.Await(v, wf, 10) # X.PropertyNotify AND NOT v.dead THEN
            X.XSync(v.dpy, X.False)
          END
        END
      FINALLY
        Exit(v);
        Thread.Acquire(ch)
      END
    EXCEPT
      TrestleComm.Failure =>    (* skip *)
    END
  END Sync;

PROCEDURE SetCursor (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
        TrestleComm.Failure =>  (* skip *)
      END
    END
  END SetCursor;

PROCEDURE TypeCodeToXType (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;

PROCEDURE SelectionAtom (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;

PROCEDURE WriteUp (           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 X.Atom;
    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);
            XClientF.FreeAtom(v, multi[1]);
            XClientF.FreeAtom(v, multi[3])
          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;

PROCEDURE ReadUp (           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;

PROCEDURE SetXShape (v: T; ch: VBT.T) =
  (* LL = VBT.mu *)
  VAR
    xhints       : X.XSizeHints;
    seqno        : Ctypes.UnsignedLong;
    mustReshape                        := FALSE;
    width, height: CARDINAL;
    ur           : Child               := ch.upRef;
    wf                                 := NEW(MessageWaitFor);
    st           : XScreenType.T       := ch.st;
  BEGIN
    WITH s  = VBTClass.GetShapes(ch),
         sh = s[Axis.T.Hor],
         sv = s[Axis.T.Ver]           DO
      IF sv.hi < VBT.DefaultShape.hi OR sh.hi < VBT.DefaultShape.hi THEN
        xhints.flags := X.PMinSize + X.PMaxSize
      ELSE
        xhints.flags := X.PMinSize
      END;
      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);
      TRY
        Enter(v);
        TRY
          IF ur.userPosition THEN
            INC(xhints.flags, X.USPosition + X.USSize)
          ELSE
            INC(xhints.flags, X.PPosition + X.PSize)
          END;
          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 ((sh.pref # ur.width) OR (sv.pref # ur.height))
               AND (sh.pref # 0) AND (sv.pref # 0) THEN
            seqno := X.XNextRequest(v.dpy);
            X.XResizeWindow(v.dpy, ur.w, sh.pref, sv.pref);
            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
        TrestleComm.Failure =>  (* skip *)
      END
    END
  END SetXShape;

TYPE
  MessageWaitFor =
    SimpleWaitFor OBJECT atm: X.Atom OVERRIDES match := MessageMatch END;

PROCEDURE MessageMatch (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;

PROCEDURE NewShape (v: T; ch: VBT.T) RAISES {} =
  BEGIN
    IF ch.st = NIL THEN RETURN END;
    VBT.Mark(v)
  END NewShape;

PROCEDURE Redisplay (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;

PROCEDURE ToName (trsl: T; a: X.Atom): TEXT RAISES {TrestleComm.Failure} =
  BEGIN
    TRY
      RETURN trsl.atoms.get(a)
    EXCEPT
      IntegerToTextTable.NotFound =>
        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
  END ToName;

PROCEDURE ToAtom (trsl: T; name: TEXT): X.Atom
  RAISES {TrestleComm.Failure} =
  BEGIN
    TRY
      RETURN trsl.names.get(name)
    EXCEPT
      TextToIntegerTable.NotFound =>
        VAR
          s         := M3toC.TtoS(name);
          a: X.Atom;
        BEGIN
          TRY
            a := X.XInternAtom(trsl.dpy, s, X.False)
          FINALLY
            M3toC.FreeS(s)
          END;
          EVAL trsl.atoms.put(a, name);
          EVAL trsl.names.put(name, a);
          RETURN a
        END
    END
  END ToAtom;

PROCEDURE Acquire (           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: INTEGER;
  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
      TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled)
    END
  END Acquire;

PROCEDURE Release (           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
      TrestleComm.Failure =>    (* skip *)
    END
  END Release;

PROCEDURE Forge (                    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;

PROCEDURE DoForge (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, ADR(data), 0);
        EVAL XClientF.Await(self.v, wf, 5);
      FINALLY
        Exit(self.v)
      END
    EXCEPT
      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;

PROCEDURE Put (                    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;
  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 = LOOPHOLE(ev.data, ARRAY [0 .. 4] OF INTEGER) 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, ADR(ev));
      FINALLY
        Exit(v)
      END
    EXCEPT
      TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled)
    END
  END Put;

VAR namebuf: ARRAY [0..255] OF Ctypes.char;

PROCEDURE Init () =
  BEGIN
    EVAL Unix.gethostname(ADR(namebuf[0]), NUMBER(namebuf));
    MyHostName := X.XTextProperty{ADR(namebuf[0]), Xatom.XA_STRING, 8,
                                  Cstring.strlen(ADR(namebuf[0])) + 1};
    TrestleClass.RegisterConnectClosure(
      NEW(TrestleClass.ConnectClosure, apply := XClientF.DoConnect))
  END Init;

BEGIN
END XClient.