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 Mar 17 11:12:50 PST 1995 by msm
modified on Thu Feb 2 13:56:06 PST 1995 by kalsow
modified on Mon Nov 22 13:47:01 PST 1993 by steveg
modified on Fri Jul 23 10:26:43 PDT 1993 by sfreeman
modified on Mon Feb 24 13:59:46 PST 1992 by muller
<*PRAGMA LL*>
UNSAFE MODULE XProperties;
IMPORT XClient, XClientF, VBTClass, TrestleOnX, X, Thread, VBT, Cstring,
TrestleComm, Text, Ctypes, RefSeq, XConfCtl, TrestleImpl, Point;
-- initialise X client --
PROCEDURE InitialiseXClient (xcon: XClient.T) RAISES {TrestleComm.Failure} =
BEGIN
WITH wf = NEW(SelRequestWaitFor) DO
wf.timelimit := -1;
wf.types[0] := X.SelectionRequest;
XClientF.RegisterWaiter(xcon, wf);
END;
WITH wf = NEW(ConfCtlWaitFor) DO
wf.timelimit := -1;
wf.types[0] := X.ClientMessage;
wf.atom := XClient.ToAtom(xcon, "XMUX_MESSAGE");
XClientF.RegisterWaiter(xcon, wf)
END
END InitialiseXClient;
TYPE
SelRequestWaitFor = XClientF.WaitFor OBJECT
OVERRIDES
match := SRWFMatch;
notify := SRWFNotify;
END;
ConfCtlWaitFor = XClientF.WaitFor OBJECT
atom: X.Atom
OVERRIDES
match := CctMatch;
notify := CctNotify;
END;
PROCEDURE SRWFMatch (<* UNUSED*> wf: XClientF.WaitFor;
READONLY ev: X.XEvent ):
BOOLEAN =
BEGIN
RETURN LOOPHOLE(ADR(ev), X.XAnyEventStar).type = X.SelectionRequest;
END SRWFMatch;
PROCEDURE CctMatch (wf: ConfCtlWaitFor; READONLY ev: X.XEvent): BOOLEAN =
BEGIN
IF LOOPHOLE(ADR(ev), X.XAnyEventStar).type # X.ClientMessage THEN
RETURN FALSE
END;
WITH e = LOOPHOLE(ADR(ev), X.XClientMessageEventStar) DO
RETURN e.message_type = wf.atom
END
END CctMatch;
PROCEDURE SRWFNotify ( wf : XClientF.WaitFor;
READONLY ev : X.XEvent;
xcon: XClient.T ) =
BEGIN
WITH e = LOOPHOLE(ADR(ev), X.XSelectionRequestEventStar) DO
FOR s := FIRST(xcon.sel^) TO LAST(xcon.sel^) DO
IF xcon.sel[s].name = e.selection THEN
StartSelection(xcon, e.requestor, e.target, e.property,
VBT.Selection{s}, e.time);
END;
END;
END;
XClientF.RegisterWaiter(xcon, wf); (* wf will have been removed from
the list *)
END SRWFNotify;
VAR
cctMu := NEW(MUTEX);
cctCond := NEW(Thread.Condition);
cctList, focList := NEW(RefSeq.T).init();
cctThread : Thread.T := NIL;
TYPE CctClosure = Thread.Closure OBJECT OVERRIDES apply := CctApply END;
PROCEDURE CctApply (<* UNUSED *> cl: CctClosure): REFANY =
VAR
v : VBT.T;
cct: BOOLEAN;
BEGIN
LOOP
LOCK cctMu DO
WHILE cctList.size() + focList.size() = 0 DO
Thread.Wait(cctMu, cctCond)
END;
cct := cctList.size() # 0;
IF cct THEN v := cctList.remlo() ELSE v := focList.remlo() END
END;
IF cct THEN
XConfCtl.Process(v)
ELSE
LOCK VBT.mu DO
VBTClass.Mouse(
v, VBT.MouseRec{
whatChanged := VBT.Modifier.Mouse4, time := 0, cp :=
VBT.CursorPosition{Point.Origin, -1, FALSE, FALSE},
modifiers :=
VBT.Modifiers{VBT.Modifier.Mod0, VBT.Modifier.Mod1,
VBT.Modifier.Mod2, VBT.Modifier.Mod3},
clickType := VBT.ClickType.LastUp, clickCount := 0})
END
END
END
END CctApply;
PROCEDURE CctNotify ( wf : ConfCtlWaitFor;
READONLY ev : X.XEvent;
xcon: XClient.T ) =
VAR ra: REFANY;
BEGIN
WITH e = LOOPHOLE(ADR(ev), X.XClientMessageEvent_l_star) DO
IF xcon.vbts.get(e.window, ra) THEN
LOCK cctMu DO
IF e.data[0] = 2 THEN
cctList.addhi(ra);
ELSIF e.data[0] = 1 AND e.data[1] = 0 THEN
focList.addhi(ra);
END;
IF cctThread = NIL THEN
cctThread := Thread.Fork(NEW(CctClosure))
ELSE
Thread.Signal(cctCond)
END
END
END
END;
XClientF.RegisterWaiter(xcon, wf); (* wf will have been removed from
the list *)
END CctNotify;
-- start selection --
TYPE
SelectionClosure = Thread.SizedClosure OBJECT
trsl : XClient.T;
w : X.Window;
type, prop: X.Atom;
sel : VBT.Selection;
ts : VBT.TimeStamp;
OVERRIDES
apply := DoXSelection
END;
PROCEDURE CopyBytes(src, dst: ADDRESS; n: INTEGER) =
BEGIN
EVAL Cstring.memcpy(dst, src, n)
END CopyBytes;
PROCEDURE StartSelection (trsl : XClient.T;
w : X.Window;
type, prop: X.Atom;
sel : VBT.Selection;
ts : VBT.TimeStamp;
stackSize := 20000) =
BEGIN
EVAL Thread.Fork(
NEW(SelectionClosure, stackSize := stackSize, trsl := trsl,
w := w, type := type, prop := prop, sel := sel, ts := ts));
END StartSelection;
PROCEDURE ExtendSel (VAR sa: XClientF.SelArray; s: VBT.Selection) =
VAR
n := NUMBER(sa^);
na: XClientF.SelArray;
BEGIN
IF s.sel > LAST(sa^) THEN
na := NEW(XClientF.SelArray, MAX(2 * n, s.sel + 1));
SUBARRAY(na^, 0, n) := sa^;
FOR i := n TO LAST(na^) DO na[i] := XClientF.SelectionRecord{} END;
sa := na
END
END ExtendSel;
PROCEDURE ExtendOwns (VAR sa: XClientF.OwnsArray; s: VBT.Selection) =
VAR
n := NUMBER(sa^);
na: XClientF.OwnsArray;
BEGIN
IF s.sel > LAST(sa^) THEN
na := NEW(XClientF.OwnsArray, MAX(2 * n, s.sel + 1));
SUBARRAY(na^, 0, n) := sa^;
FOR i := n TO LAST(na^) DO na[i] := FALSE END;
sa := na
END
END ExtendOwns;
PROCEDURE DoXSelection (cl: SelectionClosure): REFANY RAISES {} =
VAR
failed := FALSE;
alloc := FALSE;
v : VBT.T;
BEGIN
TRY
TRY
TrestleOnX.Enter(cl.trsl);
TRY
ExtendSel(cl.trsl.sel, cl.sel);
v := cl.trsl.sel[cl.sel.sel].v;
IF v = NIL THEN failed := TRUE; RETURN NIL END;
IF cl.prop = X.None THEN
cl.prop := XClientF.NewAtom(v);
alloc := TRUE
END
FINALLY
TrestleOnX.Exit(cl.trsl)
END;
failed := NOT EvalSelection(cl, v, cl.type, cl.prop)
FINALLY
TrestleOnX.Enter(cl.trsl);
TRY
VAR ev: X.XSelectionEvent;
BEGIN
ev.type := X.SelectionNotify;
ev.display := cl.trsl.dpy;
ev.requestor := cl.w;
ev.selection := cl.trsl.sel[cl.sel.sel].name;
ev.target := cl.type;
IF failed THEN
ev.property := X.None
ELSE
ev.property := cl.prop
END;
ev.time := cl.ts;
EVAL X.XSendEvent(cl.trsl.dpy, cl.w, X.False, 0,
LOOPHOLE(ADR(ev),X.XEventStar));
IF alloc THEN XClientF.FreeAtom(v, cl.prop) END
END
FINALLY
TrestleOnX.Exit(cl.trsl)
END
END
EXCEPT
X.Error, TrestleComm.Failure => (* skip *)
END;
RETURN NIL
END DoXSelection;
PROCEDURE EvalSelection (cl : SelectionClosure;
owner : VBT.T;
type, prop: X.Atom ): BOOLEAN
RAISES {TrestleComm.Failure} =
VAR
ntype, nprop: X.Atom;
format : INTEGER;
data : REF ARRAY OF CHAR;
p : UNTRACED REF X.Atom;
anyFail := FALSE;
ts : VBT.TimeStamp;
multiple, atompair, targets, timestamp, string, text, atom, intatom,
delete, insprop, inssel, null, sym, rsym, length: X.Atom;
res: TEXT;
ur : XClientF.Child;
BEGIN
TrestleOnX.Enter(cl.trsl);
TRY
length := XClient.ToAtom(cl.trsl, "LENGTH");
multiple := XClient.ToAtom(cl.trsl, "MULTIPLE");
atompair := XClient.ToAtom(cl.trsl, "ATOM_PAIR");
targets := XClient.ToAtom(cl.trsl, "TARGETS");
timestamp := XClient.ToAtom(cl.trsl, "TIMESTAMP");
string := XClient.ToAtom(cl.trsl, "STRING");
text := XClient.ToAtom(cl.trsl, "TEXT");
atom := XClient.ToAtom(cl.trsl, "ATOM");
intatom := XClient.ToAtom(cl.trsl, "INTEGER");
delete := XClient.ToAtom(cl.trsl, "DELETE");
insprop := XClient.ToAtom(cl.trsl, "INSERT_PROPERTY");
inssel := XClient.ToAtom(cl.trsl, "INSERT_SELECTION");
null := XClient.ToAtom(cl.trsl, "NULL");
ExtendSel(cl.trsl.sel, cl.sel);
ts := cl.trsl.sel[cl.sel.sel].ts
FINALLY
TrestleOnX.Exit(cl.trsl)
END;
IF type = multiple THEN
IF NOT UnlockedGetProp(cl.trsl, cl.w, prop, ntype, data, format)
OR format # 32 OR ntype # atompair OR NUMBER(data^) MOD 8 # 0 THEN
RETURN FALSE
END;
FOR i := 0 TO LAST(data^) BY 8 DO
p := LOOPHOLE(ADR(data[i]), UNTRACED REF X.Atom);
ntype := p^;
p := LOOPHOLE(ADR(data[i + 4]), UNTRACED REF X.Atom);
nprop := p^;
IF NOT EvalSelection(cl, owner, ntype, nprop) THEN
p^ := X.None;
anyFail := TRUE
END
END;
IF anyFail THEN
UnlockedPutProp(cl.trsl, cl.w, prop, atompair, data^, 32)
END
ELSIF type = targets THEN
VAR
td := ARRAY [0 .. 4] OF
Ctypes.int{multiple, targets, timestamp, string, text};
BEGIN
UnlockedPutProp(cl.trsl, cl.w, prop, atom,
LOOPHOLE(td, ARRAY [0 .. 19] OF CHAR), 32)
END
ELSIF type = timestamp THEN
VAR tts: Ctypes.int := ts; BEGIN
UnlockedPutProp(cl.trsl, cl.w, prop, intatom,
LOOPHOLE(tts, ARRAY [0 .. 3] OF CHAR), 32)
END
ELSIF type = text OR type = string THEN
TRY
TYPECASE owner.read(cl.sel, TYPECODE(TEXT)).toRef() OF
NULL => RETURN FALSE
| TEXT (t) =>
VAR buf := NEW(UNTRACED REF ARRAY OF CHAR, Text.Length(t));
BEGIN
IF Text.Length(t) > 0 THEN Text.SetChars(buf^, t) END;
UnlockedPutProp(cl.trsl, cl.w, prop, string, buf^, 8);
DISPOSE(buf)
END
ELSE
RETURN FALSE
END
EXCEPT
VBT.Error => RETURN FALSE
END;
ELSIF type = delete THEN
TRY
owner.write(cl.sel, VBT.FromRef(""), TYPECODE(TEXT))
EXCEPT
VBT.Error => RETURN FALSE
END
ELSIF type = insprop THEN
IF NOT UnlockedGetProp(cl.trsl, cl.w, prop, ntype, data, format)
OR ntype # string OR format # 8 THEN
RETURN FALSE
END;
TRY
owner.write(
cl.sel, VBT.FromRef(Text.FromChars(data^)), TYPECODE(TEXT))
EXCEPT
VBT.Error => RETURN FALSE
END
ELSIF type = inssel THEN
TrestleOnX.Enter(cl.trsl);
TRY
ur := owner.upRef;
IF ur = NIL OR ur.xcage = X.None THEN RETURN FALSE END;
IF NOT GetProp(cl.trsl, cl.w, prop, ntype, data, format)
OR ntype # atompair OR format # 32 OR NUMBER(data^) # 8 THEN
RETURN FALSE
END;
p := LOOPHOLE(ADR(data[0]), UNTRACED REF X.Atom);
nprop := p^;
p := LOOPHOLE(ADR(data[4]), UNTRACED REF X.Atom);
ntype := p^;
sym := XClientF.NewAtom(cl.trsl);
TRY
IF ntype = text THEN ntype := string END;
rsym :=
AwaitConversion(cl.trsl, ur.xcage, nprop, ntype, sym, cl.ts);
IF rsym # sym THEN XClientF.FreeAtom(cl.trsl, sym) END;
res := ReadXSelFromProp(cl.trsl, ur.xcage, rsym, ntype);
XClientF.FreeAtom(cl.trsl, sym);
EXCEPT
VBT.Error (ec) =>
IF ec # VBT.ErrorCode.TimeOut THEN
XClientF.FreeAtom(cl.trsl, sym)
END;
RETURN FALSE
END
FINALLY
TrestleOnX.Exit(cl.trsl)
END;
TRY
owner.write(cl.sel, VBT.FromRef(res), TYPECODE(TEXT))
EXCEPT
VBT.Error => RETURN FALSE
END
ELSIF type = length THEN
TRY
TYPECASE owner.read(cl.sel, TYPECODE(TEXT)).toRef() OF
NULL => RETURN FALSE
| TEXT (t) =>
VAR lnth: Ctypes.int := Text.Length(t);
BEGIN
UnlockedPutProp(cl.trsl, cl.w, prop, intatom,
LOOPHOLE(lnth, ARRAY [0 .. 3] OF CHAR), 32);
END
ELSE
RETURN FALSE
END
EXCEPT
VBT.Error => RETURN FALSE
END
ELSE
RETURN FALSE
END;
RETURN TRUE
END EvalSelection;
TYPE
SelectionWaitFor = XClientF.SimpleWaitFor OBJECT
sel, type, prop: X.Atom;
sent : BOOLEAN := FALSE;
ts : VBT.TimeStamp := 0;
OVERRIDES
match := SelectionMatch;
END;
PROCEDURE SelectionMatch (wf: SelectionWaitFor; READONLY ev: X.XEvent):
BOOLEAN =
BEGIN
IF NOT XClientF.SimpleWaitFor.match(wf, ev) THEN RETURN FALSE END;
WITH e = LOOPHOLE(ADR(ev), X.XAnyEventStar),
type = e.type DO
IF type # X.SelectionNotify THEN RETURN TRUE END;
WITH pe = LOOPHOLE(e, X.XSelectionEventStar) DO
wf.prop := pe.property;
wf.sent := pe.send_event # X.False;
RETURN
pe.selection = wf.sel AND pe.target = wf.type AND pe.time = wf.ts
END
END
END SelectionMatch;
PROCEDURE AwaitConversion (v : XClient.T;
w : X.Window;
name, type, sym: X.Atom;
ts : VBT.TimeStamp;
limit := 10): X.Atom
RAISES {VBT.Error} =
VAR
wf := NEW(SelectionWaitFor, d := w, sel := name, ts := ts,
type := type, prop := X.None);
BEGIN
TRY
wf.reqno := X.XNextRequest(v.dpy);
X.XConvertSelection(v.dpy, name, type, sym, w, ts);
wf.types[0] := 0;
wf.types[1] := X.SelectionNotify;
IF XClientF.Await(v, wf, limit) = 1 THEN
RAISE VBT.Error(VBT.ErrorCode.TimeOut)
ELSIF wf.prop = X.None THEN
IF wf.sent THEN
RAISE VBT.Error(VBT.ErrorCode.Unreadable)
ELSE
RAISE VBT.Error(VBT.ErrorCode.UnownedSelection)
END
END;
RETURN wf.prop
EXCEPT
X.Error, TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled)
END
END AwaitConversion;
PROCEDURE ReadXSelFromProp (v: XClient.T; w: X.Window; prop, type: X.Atom):
TEXT RAISES {VBT.Error} =
VAR
propType: X.Atom;
format : INTEGER;
res : REF ARRAY OF CHAR;
resT := "";
pwf := NEW(PropertyWaitFor);
BEGIN
TRY
IF NOT GetProp(v, w, prop, propType, res, format) THEN
RAISE VBT.Error(VBT.ErrorCode.Unreadable)
ELSIF propType # type AND propType # XClient.ToAtom(v, "INCR") THEN
RAISE VBT.Error(VBT.ErrorCode.WrongType)
ELSIF propType = type THEN
IF type # XClient.ToAtom(v, "STRING") THEN Crash() END;
RETURN Text.FromChars(res^)
ELSE
pwf.types[0] := X.PropertyNotify;
pwf.d := w;
pwf.a := prop;
LOOP
IF XClientF.Await(v, pwf, 10) = 1 THEN
RAISE VBT.Error(VBT.ErrorCode.TimeOut)
ELSIF pwf.state = X.PropertyNewValue THEN
IF NOT GetProp(v, w, prop, propType, res, format) THEN
RAISE VBT.Error(VBT.ErrorCode.Unreadable)
ELSIF propType # type THEN
RAISE VBT.Error(VBT.ErrorCode.WrongType)
ELSIF NUMBER(res^) = 0 THEN
IF type # XClient.ToAtom(v, "STRING") THEN Crash() END;
RETURN resT
END;
resT := resT & Text.FromChars(res^)
END
END
END
EXCEPT
TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled)
END
END ReadXSelFromProp;
REVEAL
PropertyWaitFor =
PWF_Public BRANDED OBJECT OVERRIDES match := PropertyMatch END;
PROCEDURE PropertyMatch (wf: PropertyWaitFor; READONLY ev: X.XEvent):
BOOLEAN =
BEGIN
IF NOT XClientF.SimpleWaitFor.match(wf, ev) THEN RETURN FALSE END;
WITH e = LOOPHOLE(ADR(ev), X.XAnyEventStar),
type = e.type DO
IF type # X.PropertyNotify THEN RETURN TRUE END;
WITH pe = LOOPHOLE(e, X.XPropertyEventStar) DO
wf.ts := pe.time;
wf.state := pe.state;
RETURN pe.atom = wf.a
END
END
END PropertyMatch;
PROCEDURE UnlockedPutProp ( trsl : XClient.T;
w : X.Window;
prop, type: X.Atom;
READONLY data : ARRAY OF CHAR;
format : INTEGER )
RAISES {TrestleComm.Failure} =
BEGIN
TrestleOnX.Enter(trsl);
TRY
PutProp(trsl, w, prop, type, data, format)
FINALLY
TrestleOnX.Exit(trsl)
END
END UnlockedPutProp;
PROCEDURE PutProp ( v : XClient.T;
w : X.Window;
prop, type: X.Atom;
READONLY data : ARRAY OF CHAR;
format : INTEGER )
RAISES {TrestleComm.Failure} =
VAR
st := 0;
len := NUMBER(data);
n : INTEGER;
mode := X.PropModeReplace;
maxSize := 4 * (X.XMaxRequestSize(v.dpy) - 50);
p : ADDRESS;
format8 := format DIV 8;
BEGIN
TRY
REPEAT
n := MIN(len - st, maxSize);
IF n # 0 THEN p := ADR(data[st]) ELSE p := ADR(p) END;
X.XChangeProperty(
v.dpy, w, prop, type, format, mode, p, n DIV format8);
INC(st, n);
mode := X.PropModeAppend
UNTIL st = len;
EXCEPT X.Error => RAISE TrestleComm.Failure END;
END PutProp;
PROCEDURE UnlockedGetProp ( trsl : XClient.T;
w : X.Window;
prop : X.Atom;
VAR (*OUT*) type : X.Atom;
VAR (*OUT*) data : REF ARRAY OF CHAR;
VAR (*OUT*) format: INTEGER ):
BOOLEAN RAISES {TrestleComm.Failure} =
BEGIN
TrestleOnX.Enter(trsl);
TRY
RETURN GetProp(trsl, w, prop, type, data, format)
FINALLY
TrestleOnX.Exit(trsl)
END
END UnlockedGetProp;
PROCEDURE GetProp ( v : XClient.T;
w : X.Window;
prop : X.Atom;
VAR (*OUT*) type : X.Atom;
VAR (*OUT*) res : REF ARRAY OF CHAR;
VAR (*OUT*) format: INTEGER ): BOOLEAN
RAISES {TrestleComm.Failure} =
VAR
len, remaining: INTEGER;
data : Ctypes.char_star;
maxSize := X.XMaxRequestSize(v.dpy) - 50;
st := 0;
fmt: Ctypes.int := 0;
BEGIN
TRY
IF X.XGetWindowProperty(
v.dpy, w, prop, 0, maxSize, X.True, X.AnyPropertyType, ADR(type),
ADR(fmt), ADR(len), ADR(remaining),
LOOPHOLE(ADR(data), Ctypes.unsigned_char_star_star)) # X.Success THEN
RETURN FALSE
END;
format := fmt;
len := len * (format DIV 8);
res := NEW(REF ARRAY OF CHAR, len + remaining);
LOOP
IF len # 0 THEN
CopyBytes(data, ADR(res[st]), MIN(len, NUMBER(res^) - st))
END;
INC(st, len);
X.XFree(data);
IF remaining = 0 OR st >= NUMBER(res^) THEN
RETURN remaining = 0 AND st = NUMBER(res^)
END;
IF X.XGetWindowProperty(
v.dpy, w, prop, st DIV 4, maxSize, X.True, X.AnyPropertyType,
ADR(type), ADR(fmt), ADR(len), ADR(remaining),
LOOPHOLE(ADR(data), Ctypes.unsigned_char_star_star))
# X.Success THEN
RETURN FALSE
END;
format := fmt;
IF len = 0 THEN X.XFree(data); RETURN FALSE END;
len := len * (format DIV 8)
END
EXCEPT X.Error => RAISE TrestleComm.Failure END;
END GetProp;
EXCEPTION FatalError;
PROCEDURE Crash() =
<* FATAL FatalError *>
BEGIN
RAISE FatalError
END Crash;
BEGIN
END XProperties.