Copyright (C) 1994, Digital Equipment Corp.
by Steve Glassman, Mark Manasse and Greg Nelson
<*PRAGMA LL*> UNSAFE MODULE-- initialise X client --; IMPORT XClient, XClientF, VBTClass, TrestleOnX, X, Thread, VBT, Cstring, TrestleComm, Text, Ctypes, RefSeq, XConfCtl, TrestleImpl, Point; XProperties
PROCEDURE-- start selection --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; PROCEDURESRWFMatch (<* UNUSED*> wf: XClientF.WaitFor; READONLY ev: X.XEvent ): BOOLEAN = BEGIN RETURN LOOPHOLE(ADR(ev), X.XAnyEventStar).type = X.SelectionRequest; END SRWFMatch; PROCEDURECctMatch (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; PROCEDURESRWFNotify ( 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; PROCEDURECctApply (<* 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; PROCEDURECctNotify ( 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;
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; PROCEDURECopyBytes (src, dst: ADDRESS; n: INTEGER) = BEGIN EVAL Cstring.memcpy(dst, src, n) END CopyBytes; PROCEDUREStartSelection (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; PROCEDUREExtendSel (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; PROCEDUREExtendOwns (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; PROCEDUREDoXSelection (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; PROCEDUREEvalSelection (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; PROCEDURESelectionMatch (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; PROCEDUREAwaitConversion (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; PROCEDUREReadXSelFromProp (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; PROCEDUREPropertyMatch (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; PROCEDUREUnlockedPutProp ( 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; PROCEDUREPutProp ( 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; PROCEDUREUnlockedGetProp ( 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; PROCEDUREGetProp ( 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; PROCEDURECrash () = <* FATAL FatalError *> BEGIN RAISE FatalError END Crash; BEGIN END XProperties.