ui/src/nt/NTClient.m3


Copyright (C) 1994, Digital Equipment Corp.
 by Steve Glassman, Mark Manasse and Greg Nelson 

<*PRAGMA LL*>

UNSAFE MODULE NTClient;

IMPORT Fmt, NT, NTClientF, NTMsgs, NTPaint, NTScreenType, Point,
       ProperSplit, Rect, Trestle, TrestleClass, TrestleComm,
       TrestleImpl, TrestleOnNT, VBT, VBTClass, VBTRep, WinUser;
IMPORT NTDebug;

FROM TrestleClass IMPORT Decoration;
FROM NTClientF IMPORT Child;
FROM TrestleOnNT IMPORT Enter, Exit;

REVEAL
  T = NTPaint.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;
        getScreens       := GetScreens;
        screenOf         := ScreenOf;

installOffscreen := InstallOffscreen; setColorMap := SetColorMap; allCeded := AllCeded; tickTime := TickTime;

        trestleId        := TrestleID;
        windowId         := WindowID;

updateBuddies := UpdateBuddies;

      END;

PROCEDURE BeChild (trsl: T; ch: VBT.T) RAISES {} =
  BEGIN
    IF ch.upRef = NIL THEN
      ch.upRef := NEW(Child, ch := ch, owns := NEW(NTClientF.OwnsArray, 0))
    ELSE
      WITH ur = NARROW(ch.upRef, Child) DO
        ur.ch := ch;
        ur.owns := NEW(NTClientF.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 Crash() END;
    NTClientF.Delete(trsl, ch, ur)
  END Replace;

PROCEDURE SetCage (v: T; ch: VBT.T) RAISES {} =
  VAR ur: Child := ch.upRef;
  BEGIN
    WITH cage = VBTClass.Cage(ch) DO

NTDebug.PInt(NTSetCage v: , LOOPHOLE(v, INTEGER)); NTDebug.PRect( , cage.rect); NTDebug.PText(Fmt.F( inout: {%s %s}, Fmt.Bool(FALSE IN cage.inOut), Fmt.Bool(TRUE IN cage.inOut))); NTDebug.NewLine();

      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;
          ur.cage := cage;
          ur.everywhereCage := cage = VBT.EverywhereCage;
          IF NOT ur.inside THEN
            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 Attach (trsl: T; v: VBT.T) RAISES {} =
  BEGIN
    LOCK v DO LOCK trsl DO ProperSplit.Insert(trsl, NIL, v) END END
  END Attach;

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
          NTClientF.SetDecoration(trsl, v, ch, ch.hwnd, old, new)
        FINALLY
          Exit(trsl)
        END
    ELSE                         (* skip*)
    END
  END Decorate;

PROCEDURE Iconize (trsl: T; v: VBT.T) RAISES {TrestleComm.Failure} =
  VAR alreadyMapped: BOOLEAN;
  BEGIN
    alreadyMapped := v.st # NIL;
    IF alreadyMapped THEN
      VAR
        ur : Child         := v.upRef;
      BEGIN
        Enter(trsl);
        TRY
          NT.Assert(WinUser.CloseWindow(ur.hwnd));
          NTClientF.SetTitle(trsl, v, ur);
        FINALLY
          Exit(trsl)
        END
      END
    ELSE
      NTMsgs.CreateNTWindow(trsl, v, NIL, iconic := TRUE)
    END
  END Iconize;

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                            := FALSE)
  RAISES {TrestleComm.Failure} =
  VAR
    st           : NTScreenType.T;
    alreadyMapped: BOOLEAN;
  BEGIN
    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;
    IF alreadyMapped THEN
      VAR ur: Child := v.upRef;
      BEGIN
        Enter(trsl);
        TRY
          NT.Assert(WinUser.SetWindowPos(
                      ur.hwnd, WinUser.HWND_TOP, nw.h, nw.v,
                      Rect.HorSize(v.domain), Rect.VerSize(v.domain),
                      WinUser.SWP_NOZORDER));
          IF iconic THEN
            EVAL WinUser.CloseWindow(ur.hwnd);
          ELSE
            EVAL WinUser.OpenIcon(ur.hwnd);
          END;
          NTClientF.SetTitle(trsl, v, ur);
        FINALLY
          Exit(trsl)
        END
      END
    ELSE
      NTMsgs.CreateNTWindow(trsl, v, st, nw.h, nw.v, iconic := iconic)
    END
  END InnerOverlap;

PROCEDURE MoveNear (trsl: T; v, w: VBT.T) RAISES {TrestleComm.Failure} =
  VAR
    st: NTScreenType.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 THEN w := NIL END
    END;
    IF w # NIL THEN
      st := w.st;
      id := st.screenID;
      Enter(trsl);
      TRY
        NTClientF.ValidateNW(trsl, ch, st);
        nw := Point.Add(nw, ch.nw)
      FINALLY
        Exit(trsl)
      END;
    END;
    InnerOverlap(trsl, v, id, nw, w # NIL)
  END MoveNear;

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 ScreenOf (trsl: T; ch: VBT.T; READONLY pt: Point.T):
  Trestle.ScreenOfRec RAISES {} =
  VAR
    ur : Child               := ch.upRef;
    st : NTScreenType.T      := ch.st;
    res: Trestle.ScreenOfRec;
  BEGIN
    res.trsl := trsl;
    IF st = NIL OR ur = NIL THEN
      res.id := Trestle.NoScreen
    ELSE
      TRY
        Enter(trsl);
        TRY
          res.id := st.screenID;
          res.dom := st.rootDom;
          IF ur.hwnd # NT.CNULL THEN
            NTClientF.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 TrestleID(t: T): TEXT =
  BEGIN
    RETURN t.inst
  END TrestleID;

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

PROCEDURE Init () =
  BEGIN
    TrestleClass.RegisterConnectClosure(
      NEW(TrestleClass.ConnectClosure, apply := NTClientF.DoConnect));
    NTMsgs.Init();
  END Init;

EXCEPTION Fatal;

PROCEDURE Crash() =
  <* FATAL Fatal *>
  BEGIN
    RAISE Fatal;
  END Crash;

BEGIN
END NTClient.