Copyright (C) 1994, Digital Equipment Corp.
by Steve Glassman, Mark Manasse and Greg Nelson
<*PRAGMA LL*> UNSAFE MODULEIMPORT NTDebug;; IMPORT Fmt, NT, NTClientF, NTMsgs, NTPaint, NTScreenType, Point, ProperSplit, Rect, Trestle, TrestleClass, TrestleComm, TrestleImpl, TrestleOnNT, VBT, VBTClass, VBTRep, WinUser; NTClient
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.