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 Fri Aug 2 11:12:59 PDT 1996 by msm
modified on Fri Feb 18 16:17:16 PST 1994 by kalsow
modified on Wed Nov 24 09:16:54 PST 1993 by steveg
modified on Fri Oct 29 16:22:55 PDT 1993 by sfreeman
modified on Fri May 7 16:53:30 PDT 1993 by mjordan
modified on Fri Jan 29 11:55:41 PST 1993 by jdd
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*>
Partitioning following the efforts of
Steve.Freeman@computer-lab.cambridge.ac.uk - 92-05-13
UNSAFE MODULE XClientF;
IMPORT XClient, TrestleOnX, TrestleClass, Trestle, Rect, ProperSplit,
IntRefTbl, IntTextTbl, TextIntTbl, X, XEventQueue, Thread,
XAtomQueue, XScreenType, VBT, Ctypes, TrestleComm, Fmt, XProperties,
RTParams, KeyboardKey, RTHeapRep,
VBTClass, Env, M3toC, XInput, XMessenger, Split, Text,
IP, ASCII, XExtensions, IntIntTbl, XClientExt, TrslOnXF;
FROM XClient IMPORT T;
REVEAL
SimpleWaitFor = SimpleWaitForPublic BRANDED OBJECT
OVERRIDES
match := SimpleMatch;
notify := SimpleNotify;
END;
T_Abs = T_Ext BRANDED OBJECT
await: WaitFor := NIL; (* list of awaited events *)
awaitCount := ARRAY [0 .. X.LASTEvent - 1] OF INTEGER{0, ..};
(* awaitCount[i] is the number of awaited events that might
match an event of type i. *)
awaitCountExt: IntIntTbl.T := NIL;
(* X extensions use event types > X.LastEvent, but we don't
know what values, so keep any extension values in a table *)
coverage : CARDINAL := 0;
atomQ := XAtomQueue.Empty;
atomCount := 0;
(* atomQ contains atoms that are available for transferring
selections; atomCount is the number of atoms that have been
created solely for this purpose. *)
meterMaid: Thread.T := NIL;
gcCursor : X.Cursor := X.None;
END;
PROCEDURE SimpleMatch (wf: SimpleWaitFor; READONLY ev: X.XEvent): BOOLEAN =
VAR match: BOOLEAN;
BEGIN
WITH e = LOOPHOLE(ADR(ev), X.XAnyEventStar),
type = e.type DO
IF type = 0 THEN
match := LOOPHOLE(ADR(ev), X.XErrorEventStar).serial = wf.reqno
ELSE
match := e.window = wf.d
END;
IF match THEN
FOR i := FIRST(wf.types) TO LAST(wf.types) DO
IF wf.types[i] = type THEN RETURN TRUE END
END
END;
RETURN FALSE
END
END SimpleMatch;
PROCEDURE SimpleNotify ( wf : SimpleWaitFor;
READONLY evRec: X.XEvent;
xcon : XClient.T ) =
BEGIN
wf.turn := TRUE;
wf.ev := evRec;
wf.timeout := FALSE;
Thread.Signal(wf);
WHILE wf.turn AND NOT xcon.dead DO Thread.Wait(xcon, wf); END;
END SimpleNotify;
PROCEDURE StartMeterMaid (trsl: T; stackSize := 20000) =
BEGIN
EVAL Thread.Fork(
NEW(MeterMaidClosure, trsl := trsl, stackSize := stackSize));
END StartMeterMaid;
TYPE
MeterMaidClosure = Thread.SizedClosure OBJECT
trsl: XClient.T
OVERRIDES
apply := MeterMaid
END;
PROCEDURE MeterMaid (cl: MeterMaidClosure): REFANY RAISES {} =
VAR prev, wf: WaitFor;
BEGIN
WITH trsl = cl.trsl DO
LOOP
Thread.Pause(1.0D0);
LOCK trsl DO
prev := NIL;
wf := trsl.await;
WHILE wf # NIL DO
IF wf.timelimit = 0 OR trsl.dead THEN
DeleteWait(trsl, prev, wf);
wf.turn := TRUE;
wf.timeout := TRUE;
Thread.Signal(wf);
wf := prev
ELSIF wf.timelimit > 0 THEN
DEC(wf.timelimit)
END;
IF wf = NIL THEN
wf := trsl.await
ELSE
prev := wf;
wf := wf.next
END;
END;
IF trsl.await = NIL THEN trsl.meterMaid := NIL; RETURN NIL END
END
END
END
END MeterMaid;
PROCEDURE Kill (trsl: T) <* LL.sup = trsl *> =
BEGIN
LOCK TrestleClass.closeMu DO
IF NOT trsl.closed THEN trsl.closed := TRUE; END
END;
trsl.dead := TRUE;
Thread.Broadcast(trsl.qEmpty);
Thread.Broadcast(trsl.qNonEmpty);
Thread.Broadcast(trsl.evc);
IF trsl.meterMaid = NIL AND trsl.await # NIL THEN
StartMeterMaid(trsl)
END;
EVAL Thread.Fork(NEW(KillClosure, trsl := trsl))
END Kill;
TYPE
KillClosure =
Thread.Closure OBJECT trsl: T OVERRIDES apply := DoKill END;
PROCEDURE DoKill (self: KillClosure): REFANY RAISES {} =
BEGIN
LOCK self.trsl DO
TRY
X.XCloseDisplay(self.trsl.dpy)
EXCEPT
X.Error => (* skip *)
END
END;
Thread.Pause(60.0D0);
LOCK errMu DO
FOR i := 0 TO LAST(dpyTable^) DO
IF dpyTable[i].trsl = self.trsl THEN dpyTable[i].trsl := NIL END
END
END;
RETURN NIL
END DoKill;
PROCEDURE Await (trsl: T_Abs; wf: WaitFor; timelimit: INTEGER := -1):
INTEGER RAISES {TrestleComm.Failure} =
(* LL = trsl *)
BEGIN
IF trsl.dead THEN RETURN Timeout END;
RegisterWaiter(trsl, wf);
RETURN WaitWaiter(trsl, wf, timelimit);
END Await;
PROCEDURE DeleteWait (trsl: T; prev, wf: WaitFor) =
VAR
count: INTEGER;
type : X.Int;
BEGIN
IF prev = NIL THEN trsl.await := wf.next ELSE prev.next := wf.next END;
wf.next := NIL;
FOR i := FIRST(wf.types) TO LAST(wf.types) DO
type := wf.types[i];
WITH tbl = trsl.awaitCountExt DO
CASE type OF
| -1 => (* skip *)
| 0 .. X.LASTEvent - 1 => DEC(trsl.awaitCount[type]);
ELSE
IF tbl # NIL AND tbl.get(type, count) THEN
DEC(count);
IF count = 0 THEN
EVAL tbl.delete(type, count);
IF tbl.size() = 0 THEN trsl.awaitCountExt := NIL; END;
ELSE
EVAL tbl.put(type, count);
END;
END;
END;
END;
END
END DeleteWait;
PROCEDURE FindWaiter (trsl: T; READONLY ev: X.XEvent): WaitFor =
(* LL = trsl *)
VAR res, prev: WaitFor;
count: INTEGER;
BEGIN
WITH e = LOOPHOLE(ADR(ev), X.XAnyEventStar) DO
CASE e.type OF
| 0..X.LASTEvent - 1 =>
IF trsl.awaitCount[e.type] = 0 THEN
RETURN NIL;
END;
ELSE
IF trsl.awaitCountExt = NIL OR
NOT trsl.awaitCountExt.get(e.type, count) OR
count = 0 THEN
RETURN NIL;
END;
END;
prev := NIL;
res := trsl.await;
WHILE (res # NIL) AND NOT res.match(ev) DO
prev := res;
res := res.next
END;
IF res # NIL THEN DeleteWait(trsl, prev, res) END;
RETURN res
END
END FindWaiter;
PROCEDURE RegisterWaiter (trsl: T_Abs; wf: WaitFor) =
VAR
count: INTEGER;
type : X.Int;
BEGIN
FOR i := FIRST(wf.types) TO LAST(wf.types) DO
type := wf.types[i];
CASE type OF
| -1 => (* skip *)
| 0 .. X.LASTEvent - 1 => INC(trsl.awaitCount[type]);
ELSE
IF trsl.awaitCountExt = NIL THEN
trsl.awaitCountExt := NEW(IntIntTbl.Default).init(1);
END;
IF trsl.awaitCountExt.get(type, count) THEN
INC(count);
ELSE
count := 1;
END;
EVAL trsl.awaitCountExt.put(type, count);
END;
END;
wf.next := trsl.await;
trsl.await := wf;
END RegisterWaiter;
PROCEDURE WaitWaiter (trsl: T_Abs; wf: WaitFor; timelimit: INTEGER := -1):
INTEGER RAISES {TrestleComm.Failure} =
BEGIN
TRY
IF trsl.dead THEN RETURN Timeout END;
wf.timelimit := timelimit;
IF trsl.meterMaid = NIL THEN
trsl.meterMaid := Thread.Fork(NEW(MeterMaidClosure, trsl := trsl,
stackSize := 20000))
END;
X.XFlush(trsl.dpy);
IF X.XEventsQueued(trsl.dpy, X.QueuedAfterReading) # 0 THEN
Thread.Signal(trsl.qNonEmpty)
END;
WHILE NOT wf.turn DO Thread.Wait(trsl, wf) END;
wf.turn := FALSE;
Thread.Signal(wf);
IF wf.timeout THEN RETURN Timeout; END;
WITH e = LOOPHOLE(ADR(wf.ev), X.XAnyEventStar) DO RETURN e.type END;
EXCEPT X.Error => RAISE TrestleComm.Failure END;
END WaitWaiter;
---------- various utilities ----------
PROCEDURE ToRect (x, y, width, height: INTEGER): Rect.T =
BEGIN
RETURN
Rect.T{west := x, north := y, east := x + width, south := y + height}
END ToRect;
PROCEDURE NewAtom (v: T): X.Atom RAISES {TrestleComm.Failure} =
<*FATAL XAtomQueue.Exhausted*>
BEGIN
IF XAtomQueue.IsEmpty(v.atomQ) THEN
INC(v.atomCount);
RETURN
XClient.ToAtom(v, "_DEC_TRESTLE_NEWATOM_" & Fmt.Int(v.atomCount))
END;
RETURN XAtomQueue.Remove(v.atomQ)
END NewAtom;
PROCEDURE FreeAtom (v: T; VAR sym: X.Atom) =
BEGIN
IF sym # X.None THEN XAtomQueue.Insert(v.atomQ, sym); sym := X.None END
END FreeAtom;
PROCEDURE BackDoor (v: T; READONLY ev: X.XEvent) =
BEGIN
XEventQueue.Insert(v.errq, ev);
Thread.Signal(v.qNonEmpty)
END BackDoor;
PROCEDURE SetUngrabs (trsl: T) RAISES {TrestleComm.Failure} =
BEGIN
TRY
FOR i := FIRST(Ungrab) TO LAST(Ungrab) DO
trsl.ungrab[i] := X.XKeysymToKeycode(trsl.dpy, Ungrab[i])
END;
EXCEPT X.Error => RAISE TrestleComm.Failure END;
(* for all vbts, fix the grabs they have by ungrabbing all, and
regrabbing what we want -- someday. *)
END SetUngrabs;
PROCEDURE ValidateNW (trsl: T; ch: Child; st: XScreenType.T)
RAISES {TrestleComm.Failure} =
VAR chw: X.Window;
h, v: Ctypes.int;
BEGIN
TRY
IF NOT ch.nwValid THEN
ch.nwValid := X.XTranslateCoordinates(
trsl.dpy, ch.w, st.root, 0, 0, ADR(h),
ADR(v), ADR(chw)) # X.False;
ch.nw.v := v;
ch.nw.h := h
END;
EXCEPT X.Error => RAISE TrestleComm.Failure END;
END ValidateNW;
PROCEDURE GetDomain (ur: Child; VAR (*OUT*) width, height: CARDINAL) =
(* Return the domain of ur's X window, or 0,0 when the window is
unmapped, and clear ur.reshapeComing. LL = ur.ch.parent *)
BEGIN
IF ur.mapped THEN
width := ur.width;
height := ur.height
ELSE
width := 0;
height := 0
END;
ur.reshapeComing := FALSE
END GetDomain;
PROCEDURE AdjustCoverage (xcon: T; d: [-1 .. 1] := 0)
RAISES {TrestleComm.Failure} =
BEGIN
TRY
INC(xcon.coverage, d);
IF xcon.coverage = 0 THEN X.XFlush(xcon.dpy) END;
IF X.XEventsQueued(xcon.dpy, X.QueuedAfterReading) # 0 THEN
Thread.Signal(xcon.qNonEmpty)
END;
EXCEPT X.Error => RAISE TrestleComm.Failure END;
END AdjustCoverage;
PROCEDURE Delete (trsl: XClient.T; ch: VBT.T; ur: Child) RAISES {} =
VAR
junk: REFANY;
code := VBT.Deleted;
BEGIN
IF ur = NIL THEN RETURN END;
LOCK trsl DO
EVAL trsl.vbts.delete(ur.w, junk);
FOR s := FIRST(trsl.sel^) TO LAST(trsl.sel^) DO
IF trsl.sel[s].v = ch THEN trsl.sel[s].v := NIL END
END;
IF trsl.dead THEN code := VBT.Disconnected END;
ur.xcage := X.None
END;
ProperSplit.Delete(trsl, ur);
VBTClass.Misc(ch, VBT.MiscRec{code, VBT.NullDetail, 0, VBT.NilSel});
VBT.Discard(ch)
END Delete;
PROCEDURE Reshape (ch: VBT.T; width, height: CARDINAL; sendMoved := FALSE) =
(* Reshape ch to new width and height. If this is a no-op, but sendMoved
is true, then send a miscellaneous code. LL = VBT.mu *)
BEGIN
IF (ch.domain.east # width) OR (ch.domain.south # height) THEN
WITH new = Rect.FromSize(width, height) DO
VBTClass.Reshape(ch, new, Rect.Meet(ch.domain, new))
END
ELSIF sendMoved THEN
VBTClass.Misc(
ch, VBT.MiscRec{VBT.Moved, VBT.NullDetail, 0, VBT.NilSel})
END
END Reshape;
---------- connection management ----------
TYPE
DpyTable = REF ARRAY OF
RECORD
dpy : X.DisplayStar;
trsl: T
END;
VAR
errMu := NEW(MUTEX); (* LL > any VBT. *)
(* protection = errMu *)
dpyTable, hackDpyTable: DpyTable := NIL;
maps dpys and hack dpys to their corresponding Ts.
VAR
openMu := NEW(MUTEX); (* LL maximal *)
opening := FALSE;
firstTime := TRUE;
PROCEDURE Connect (inst: TEXT; trsl: T := NIL): Trestle.T
RAISES {TrestleComm.Failure} =
VAR
dpy, hackdpy : X.DisplayStar := NIL;
cpos, dpos : INTEGER;
machine, rest, fullinst: TEXT;
BEGIN
TRY
IF inst = NIL AND Env.Get("ARGOENABLED") # NIL THEN
inst := Env.Get("TRUE_DISPLAY");
END;
IF inst = NIL THEN inst := Env.Get("DISPLAY"); END;
IF inst = NIL THEN inst := ":0" END;
cpos := Text.FindChar(inst, ':');
dpos := Text.FindCharR(inst, '.');
IF cpos >= 0 AND Text.Length(inst) > cpos + 1
AND Text.GetChar(inst, cpos + 1) IN ASCII.Digits THEN
TRY
IF cpos = 0 THEN
machine := IP.GetCanonicalByAddr(IP.GetHostAddr());
ELSE
machine := Text.Sub(inst, 0, cpos);
rest := IP.GetCanonicalByName(machine);
IF rest # NIL THEN machine := rest END
END;
IF machine = NIL THEN
machine := "localhost";
END;
EXCEPT
IP.Error =>
END;
IF dpos <= cpos THEN
rest := Text.Sub(inst, cpos)
ELSE
rest := Text.Sub(inst, cpos, dpos - cpos)
END;
IF machine = NIL THEN
machine := "localhost";
END;
fullinst := machine & rest;
ELSE
fullinst := inst
END;
WITH s = M3toC.SharedTtoS(inst) DO
TRY
LOCK openMu DO
IF firstTime THEN
TrslOnXF.Init();
firstTime := FALSE;
EVAL Thread.Fork(NEW(InitClosure))
END;
opening := TRUE
END;
dpy := X.XOpenDisplay(s);
IF doHack THEN
TRY
hackdpy := X.XOpenDisplay(s)
EXCEPT
X.Error => hackdpy := NIL
END
END
FINALLY
M3toC.FreeSharedS(inst, s);
LOCK openMu DO opening := FALSE END;
END
END;
IF dpy = NIL THEN
IF hackdpy = NIL THEN
RAISE TrestleComm.Failure
ELSE
dpy := hackdpy;
hackdpy := NIL
END
END;
IF trsl = NIL THEN trsl := NEW(T) END;
trsl.dpy := dpy;
IF trsl.st = NIL THEN trsl.st := NEW(VBT.ScreenType) END;
trsl.inst := inst;
trsl.fullinst := fullinst;
(* The st is irrelevant except that it must be non-NIL so that
marking the trsl for redisplay is not a noop. *)
trsl.gcCursor := X.None;
TrestleOnX.Enter(trsl);
TRY
LOCK errMu DO
WITH table = dpyTable,
hack = hackDpyTable DO
IF table = NIL THEN
table := NEW(DpyTable, 1);
IF doHack THEN hack := NEW(DpyTable, 1) END
ELSE
WITH new = NEW(DpyTable, NUMBER(table^) + 1) DO
FOR i := 0 TO LAST(table^) DO new[i + 1] := table[i] END;
table := new
END;
IF doHack AND hackdpy # NIL THEN
WITH new = NEW(DpyTable, NUMBER(hack^) + 1) DO
FOR i := 0 TO LAST(hack^) DO new[i + 1] := hack[i] END;
hack := new
END
END
END;
table[0].trsl := trsl;
table[0].dpy := trsl.dpy;
IF doHack AND hackdpy # NIL THEN
hack[0].trsl := trsl;
hack[0].dpy := hackdpy
END
END
END;
trsl.sel := NEW(SelArray, 0);
trsl.vbts := NEW(IntRefTbl.Default).init();
trsl.atoms := NEW(IntTextTbl.Default).init();
trsl.names := NEW(TextIntTbl.Default).init();
trsl.evc := NEW(Thread.Condition);
trsl.qEmpty := NEW(Thread.Condition);
trsl.qNonEmpty := NEW(Thread.Condition);
trsl.defaultScreen := X.XDefaultScreen(trsl.dpy);
trsl.screens :=
NEW(REF ARRAY OF XScreenType.T, X.XScreenCount(trsl.dpy));
trsl.takeFocus := XClient.ToAtom(trsl, "WM_TAKE_FOCUS");
trsl.wmMoved := XClient.ToAtom(trsl, "WM_MOVED");
trsl.decTakeFocus := XClient.ToAtom(trsl, "DEC_WM_TAKE_FOCUS");
trsl.protocols := XClient.ToAtom(trsl, "WM_PROTOCOLS");
trsl.deleteWindow := XClient.ToAtom(trsl, "WM_DELETE_WINDOW");
trsl.miscAtom := XClient.ToAtom(trsl, "_DEC_TRESTLE_MISCCODE");
trsl.paNewScreen := XClient.ToAtom(trsl, "_PALO_ALTO_NEW_SCREEN");
trsl.paNewDisplay :=
XClient.ToAtom(trsl, "_PALO_ALTO_NEW_DISPLAY");
trsl.paAddDisplay :=
XClient.ToAtom(trsl, "_PALO_ALTO_ADD_DISPLAY");
SetUngrabs(trsl);
XProperties.ExtendSel(trsl.sel, VBT.Target);
trsl.sel[VBT.Target.sel].name := XClient.ToAtom(trsl, "SECONDARY");
XProperties.ExtendSel(trsl.sel, VBT.Source);
trsl.sel[VBT.Source.sel].name := XClient.ToAtom(trsl, "PRIMARY");
XProperties.ExtendSel(trsl.sel, VBT.KBFocus);
trsl.sel[VBT.KBFocus.sel].name := X.None;
FixForOpenWin(trsl);
IF hackdpy # NIL THEN
TRY
trsl.gcCursor :=
X.XCreateFontCursor(hackdpy, 142 (*X.XC_trek*));
IF trsl.gcCursor # X.None THEN
VAR bg, fg: X.XColor;
BEGIN
bg.red := 65535;
bg.green := 65535;
bg.blue := 65535;
bg.flags := X.DoRed + X.DoGreen + X.DoBlue;
fg.red := 65535;
fg.green := 0;
fg.blue := 0;
fg.flags := X.DoRed + X.DoGreen + X.DoBlue;
X.XRecolorCursor(hackdpy, trsl.gcCursor, ADR(fg), ADR(bg))
END
END
EXCEPT
X.Error => trsl.gcCursor := X.None
END
END;
XProperties.InitialiseXClient(trsl);
XExtensions.InitXClient(trsl);
FINALLY
TrestleOnX.Exit(trsl, 1)
END;
FOR i := 0 TO LAST(trsl.screens^) DO
trsl.screens[i] := XScreenType.New(trsl, trsl.dpy, i)
END;
XInput.Start(trsl);
XMessenger.Start(trsl);
TrestleOnX.Enter(trsl);
TRY
FOR i := 0 TO LAST(trsl.screens^) DO
X.XSelectInput(trsl.dpy, trsl.screens[i].root, X.EnterWindowMask)
END
FINALLY
TrestleOnX.Exit(trsl, -1)
END;
EXCEPT
X.Error => RAISE TrestleComm.Failure
END;
RETURN trsl
END Connect;
PROCEDURE FixForOpenWin (trsl: T) RAISES {TrestleComm.Failure} =
VAR
selAtom := XClient.ToAtom(trsl, "_SUN_QUICK_SELECTION_KEY_STATE");
dupAtom := XClient.ToAtom(trsl, "DUPLICATE");
w := X.XRootWindow(trsl.dpy, X.XDefaultScreen(trsl.dpy));
type : X.Atom := X.None;
len, remaining: INTEGER;
format: Ctypes.int;
data : Ctypes.unsigned_char_star;
BEGIN
TRY
EVAL X.XGetWindowProperty(
trsl.dpy, w, selAtom, 0, 1, X.False, X.AnyPropertyType,
ADR(type), ADR(format), ADR(len), ADR(remaining), ADR(data));
IF type = X.None THEN
X.XChangeProperty(trsl.dpy, w, selAtom, 4 (*atom*), 32,
X.PropModeReplace,
LOOPHOLE(ADR(dupAtom), Ctypes.unsigned_char_star),
1)
END;
EXCEPT
X.Error => RAISE TrestleComm.Failure
END;
END FixForOpenWin;
PROCEDURE DoConnect (<*UNUSED*> self : TrestleClass.ConnectClosure;
inst : TEXT;
<*UNUSED*> localOnly: BOOLEAN;
VAR (*OUT*) t: Trestle.T): BOOLEAN =
BEGIN
TRY
t := Connect(inst);
RETURN TRUE
EXCEPT
TrestleComm.Failure => t := NIL; RETURN FALSE
END
END DoConnect;
CONST
Ungrab = ARRAY [0 .. 12] OF
INTEGER{
KeyboardKey.Caps_Lock, KeyboardKey.Shift_Lock,
KeyboardKey.Meta_L, KeyboardKey.Meta_R, KeyboardKey.Alt_L,
KeyboardKey.Alt_R, KeyboardKey.Super_L, KeyboardKey.Super_R,
KeyboardKey.Hyper_L, KeyboardKey.Hyper_R,
KeyboardKey.Scroll_Lock, KeyboardKey.Kana_Lock,
KeyboardKey.Num_Lock};
PROCEDURE IOError (dpy: X.DisplayStar): Ctypes.int
RAISES {X.Error} =
VAR
trsl : T := NIL;
found := FALSE;
BEGIN
IF doHack AND hackDpyTable # NIL THEN
FOR i := 0 TO LAST(hackDpyTable^) DO
IF dpy = hackDpyTable[i].dpy THEN RAISE X.Error END
END
END;
LOCK errMu DO
IF dpyTable # NIL THEN
FOR i := 0 TO LAST(dpyTable^) DO
IF dpyTable[i].dpy = dpy THEN
trsl := dpyTable[i].trsl;
found := TRUE;
EXIT
END
END
END
END;
IF trsl # NIL AND NOT trsl.dead THEN
Kill(trsl)
ELSIF NOT found THEN
LOCK openMu DO IF NOT opening THEN RETURN iohandler(dpy) END END
END;
RAISE X.Error
END IOError;
PROCEDURE Error (dpy: X.DisplayStar; errEv: X.XErrorEventStar):
Ctypes.int =
VAR
trsl : T := NIL;
ev : X.XEvent;
found := FALSE;
<* FATAL X.Error *>
BEGIN
IF doHack AND hackDpyTable # NIL THEN
FOR i := 0 TO LAST(hackDpyTable^) DO
IF dpy = hackDpyTable[i].dpy THEN RETURN 0 END
END
END;
WITH evp = LOOPHOLE(ADR(ev), X.XErrorEventStar) DO evp^ := errEv^ END;
LOCK errMu DO
IF dpyTable = NIL THEN RETURN ehandler(dpy, errEv) END;
FOR i := 0 TO LAST(dpyTable^) DO
IF dpyTable[i].dpy = dpy THEN
trsl := dpyTable[i].trsl;
found := TRUE;
EXIT
END
END
END;
IF trsl # NIL THEN
BackDoor(trsl, ev);
RETURN 0
ELSIF NOT found THEN
RETURN ehandler(dpy, errEv)
ELSE
RETURN 0
END;
END Error;
VAR
doHack := RTParams.IsPresent("StarTrek");
If doHack is TRUE, XClient will change the cursor of every installed
window to the Star Trek cursor whenever the garbage collector is
running. You can enable this with @M3StarTrek.
TYPE
GCClosure = RTHeapRep.MonitorClosure OBJECT
OVERRIDES
before := HackOn;
after := HackOff
END;
TYPE InitClosure = Thread.Closure OBJECT OVERRIDES apply := DoHackInit END;
PROCEDURE DoHackInit (<*UNUSED*> self: InitClosure): REFANY =
BEGIN
IF doHack THEN RTHeapRep.RegisterMonitor(NEW(GCClosure)) END;
RETURN NIL
END DoHackInit;
VAR hacking := FALSE;
PROCEDURE HackOn (<*UNUSED*> cl: GCClosure) =
BEGIN
HackToggle(TRUE);
hacking := TRUE
END HackOn;
PROCEDURE HackOff (<*UNUSED*> cl: GCClosure) =
BEGIN
IF hacking THEN HackToggle(FALSE); hacking := FALSE END
END HackOff;
PROCEDURE HackToggle (on: BOOLEAN) =
<*FATAL Split.NotAChild*>
VAR dead: BOOLEAN;
BEGIN
IF hackDpyTable = NIL THEN RETURN END;
FOR i := 0 TO LAST(hackDpyTable^) DO
WITH dpy = hackDpyTable[i].dpy,
trsl = hackDpyTable[i].trsl DO
dead := dpy # NIL;
IF dpy # NIL AND trsl # NIL AND NOT trsl.dead THEN
TRY
VAR v := Split.Succ(trsl, NIL);
BEGIN
WHILE v # NIL DO
VAR ur: Child := v.upRef;
BEGIN
IF ur # NIL AND ur.w # X.None AND ur.xcage # X.None THEN
IF on THEN
X.XDefineCursor(dpy, ur.w, trsl.gcCursor)
ELSE
X.XDefineCursor(dpy, ur.w, ur.csid)
END
END
END;
v := Split.Succ(trsl, v)
END
END;
X.XSync(dpy, X.True);
dead := FALSE
EXCEPT
X.Error => (* skip *)
END
END;
IF dead THEN
TRY
X.XCloseDisplay(dpy)
EXCEPT
X.Error => (* skip *)
END;
dpy := NIL
END
END
END;
END HackToggle;
VAR
ehandler := X.XSetErrorHandler(Error);
iohandler := X.XSetIOErrorHandler(IOError);
BEGIN
END XClientF.