(* 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 Mon Oct 26 18:07:08 PST 1992 by msm *)
(* modified on Mon Feb 24 13:59:46 PST 1992 by muller *)
<*PRAGMA LL*>

UNSAFE MODULE XProperties;

IMPORT XClient, XClientF, TrestleClass, VBTClass, TrestleOnX, X, Thread,
       VBT, CopyBytes, TrestleComm, Text;

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 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, ADR(ev));
            IF alloc THEN XClientF.FreeAtom(v, cl.prop) END
          END
        FINALLY
          TrestleOnX.Exit(cl.trsl)
        END
      END
    EXCEPT
      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 := ADR(data[i]);
        ntype := p^;
        p := ADR(data[i + 4]);
        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
                X.Atom{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
      UnlockedPutProp(cl.trsl, cl.w, prop, intatom,
                      LOOPHOLE(ts, ARRAY [0 .. 3] OF CHAR), 32)
    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 := ADR(data[0]);
        nprop := p^;
        p := ADR(data[4]);
        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 := 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
      TrestleComm.Failure => RAISE VBT.Error(VBT.ErrorCode.Uninstalled)
    END
  END AwaitConversion;

EXCEPTION FatalError;
<* FATAL FatalError *>

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
          RETURN Text.FromChars(res^)
        ELSE
          RAISE FatalError
        END
      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
                RETURN resT
              ELSE
                RAISE FatalError
              END
            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
    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
  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          : UNTRACED REF CHAR;
    maxSize                           := X.XMaxRequestSize(v.dpy) - 50;
    st                                := 0;
  BEGIN
    IF X.XGetWindowProperty(
         v.dpy, w, prop, 0, maxSize, X.True, X.AnyPropertyType, ADR(type),
         ADR(format), ADR(len), ADR(remaining), ADR(data)) # X.Success THEN
      RETURN FALSE
    END;
    len := len * (format DIV 8);
    res := NEW(REF ARRAY OF CHAR, len + remaining);
    LOOP
      IF len # 0 THEN
        CopyBytes.P(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(format), ADR(len), ADR(remaining), ADR(data))
           # X.Success THEN
        RETURN FALSE
      END;
      IF len = 0 THEN X.XFree(data); RETURN FALSE END;
      len := len * (format DIV 8)
    END
  END GetProp;

BEGIN
END XProperties.