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; PROCEDUREBeChild (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; PROCEDUREReplace (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; PROCEDURESetCage (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; PROCEDUREAttach (trsl: T; v: VBT.T) RAISES {} = BEGIN LOCK v DO LOCK trsl DO ProperSplit.Insert(trsl, NIL, v) END END END Attach; PROCEDUREDecorate (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; PROCEDUREIconize (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; 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 := 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; PROCEDUREMoveNear (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; 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; PROCEDUREScreenOf (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; PROCEDURETrestleID (t: T): TEXT = BEGIN RETURN t.inst END TrestleID; PROCEDUREWindowID (<* UNUSED *>t: T; v: VBT.T): TEXT = BEGIN RETURN Fmt.Unsigned(LOOPHOLE(TrestleOnNT.HWND(v), INTEGER), base := 10) END WindowID; PROCEDUREInit () = BEGIN TrestleClass.RegisterConnectClosure( NEW(TrestleClass.ConnectClosure, apply := NTClientF.DoConnect)); NTMsgs.Init(); END Init; EXCEPTION Fatal; PROCEDURECrash () = <* FATAL Fatal *> BEGIN RAISE Fatal; END Crash; BEGIN END NTClient.