MODULE ComConnect;
(**

   project   = "BlackBox"
   organization   = "www.oberon.ch"
   contributors   = "Oberon microsystems"
   version   = "System/Rsrc/About"
   copyright   = "System/Rsrc/About"
   license   = "Docu/BB-License"
   references   = "adapted from Connect sample in "Inside OLE", 2nd ed."
   changes   = ""
   issues   = ""

**)

   IMPORT COM, WinApi, WinOle, StdLog;


   
   CONST
      connPoints = 1;
      connMax = 2;
      
      eventQuack = 1; eventFlap = 2; eventPaddle = 3;
      
      SINK1 = 0; SINK2 = 1;
      
      
   TYPE
      IDuckEvents = POINTER TO
               ABSTRACT RECORD ["{00021145-0000-0000-C000-000000000046}"] (COM.IUnknown) END;
      
      
      CEnumConnectionPoints = POINTER TO RECORD (WinOle.IEnumConnectionPoints)
         cur: INTEGER;
         num: INTEGER;
         data: ARRAY connPoints OF WinOle.IConnectionPoint
      END;
      
      CEnumConnections = POINTER TO RECORD (WinOle.IEnumConnections)
         cur: INTEGER;
         num: INTEGER;
         data: ARRAY connMax OF WinOle.CONNECTDATA
      END;
      
      CConnectionPoint = POINTER TO RECORD (WinOle.IConnectionPoint)
         obj: CConnObject;
         iid: COM.GUID;
         unk: ARRAY connMax OF COM.IUnknown;
         cookies: ARRAY connMax OF INTEGER;
         conn: INTEGER;
         next: INTEGER
      END;
      
      CConnObject = POINTER TO RECORD (WinOle.IConnectionPointContainer)
         connPt: ARRAY connPoints OF CConnectionPoint
      END;
      
      CDuckEvents = POINTER TO RECORD (IDuckEvents)
         id: INTEGER;
         cookie: INTEGER
      END;
   
   
   VAR
      sink: ARRAY 2 OF CDuckEvents;
      obj: CConnObject;
      
      
   (* ---------- IDuckEvents ---------- *)
   
   PROCEDURE (this: IDuckEvents) Quack (): COM.RESULT, NEW, ABSTRACT;
   PROCEDURE (this: IDuckEvents) Flap (): COM.RESULT, NEW, ABSTRACT;
   PROCEDURE (this: IDuckEvents) Paddle (): COM.RESULT, NEW, ABSTRACT;
   
   
   (* ---------- CDuckEvents ---------- *)
   
   PROCEDURE CreateCDuckEvents (id: INTEGER; OUT new: CDuckEvents);
   BEGIN
      NEW(new);
      IF new # NIL THEN
         new.id := id;
         new.cookie := 0
      END
   END CreateCDuckEvents;
   
   PROCEDURE (this: CDuckEvents) Quack (): COM.RESULT;
   BEGIN
      StdLog.String("Sink "); StdLog.Int(this.id + 1); StdLog.String(" received Quack"); StdLog.Ln;
      RETURN WinApi.S_OK
   END Quack;
   
   PROCEDURE (this: CDuckEvents) Flap (): COM.RESULT;
   BEGIN
      StdLog.String("Sink "); StdLog.Int(this.id + 1); StdLog.String(" received Flap"); StdLog.Ln;
      RETURN WinApi.S_OK
   END Flap;
   
   PROCEDURE (this: CDuckEvents) Paddle (): COM.RESULT;
   BEGIN
      StdLog.String("Sink "); StdLog.Int(this.id + 1); StdLog.String(" received Paddle"); StdLog.Ln;
      RETURN WinApi.S_OK
   END Paddle;
   
   
   (* ---------- CEnumConnections ---------- *)
   
   PROCEDURE CreateCEnumConnections (num: INTEGER; VAR data: ARRAY OF WinOle.CONNECTDATA;
                                          OUT new: CEnumConnections);
      VAR i: INTEGER;
   BEGIN
      NEW(new);
      IF new # NIL THEN
         new.cur := 0;
         new.num := num;
         i := 0;
         WHILE i < num DO new.data[i] := data[i]; INC(i) END
      END
   END CreateCEnumConnections;
   
   PROCEDURE (this: CEnumConnections) Next (num: INTEGER;
                                                OUT elem: ARRAY [untagged] OF WinOle.CONNECTDATA;
                                                OUT [nil] fetched: INTEGER): COM.RESULT;
      VAR n: INTEGER;
   BEGIN
      n := 0;
      IF VALID(fetched) THEN fetched := 0
      ELSIF num # 1 THEN RETURN WinApi.E_POINTER
      END;
      IF this.cur < this.num THEN
         WHILE (this.cur < this.num) & (num > 0) DO
            elem[n] := this.data[this.cur];
            INC(this.cur); INC(n); DEC(num)
         END;
         IF VALID(fetched) THEN fetched := n END;
         RETURN WinApi.S_OK
      END;
      RETURN WinApi.S_FALSE
   END Next;
   
   PROCEDURE (this: CEnumConnections) Skip (num: INTEGER): COM.RESULT;
   BEGIN
      IF this.cur + num < this.num THEN
         INC(this.cur, num); RETURN WinApi.S_OK
      ELSE RETURN WinApi.S_FALSE
      END
   END Skip;
   
   PROCEDURE (this: CEnumConnections) Reset (): COM.RESULT;
   BEGIN
      this.cur := 0; RETURN WinApi.S_OK
   END Reset;
   
   PROCEDURE (this: CEnumConnections) Clone (OUT enum: WinOle.IEnumConnections): COM.RESULT;
      VAR new: CEnumConnections;
   BEGIN
      CreateCEnumConnections(this.num, this.data, new);
      IF new # NIL THEN
         new.cur := this.cur;
         enum := new;
         RETURN WinApi.S_OK
      ELSE RETURN WinApi.E_OUTOFMEMORY
      END
   END Clone;
   
   
   (* ---------- CConnectionPoint ---------- *)
   
   PROCEDURE CreateCConnectionPoint (obj: CConnObject; IN iid: COM.GUID; OUT new: CConnectionPoint);
      VAR i: INTEGER;
   BEGIN
      NEW(new);
      IF new # NIL THEN
         new.iid := iid;
         new.obj := obj;
         new.conn := 0;
         new.next := 100
      END
   END CreateCConnectionPoint;
   
   PROCEDURE (this: CConnectionPoint) GetConnectionInterface (OUT iid: COM.GUID): COM.RESULT;
   BEGIN
      iid := this.iid; RETURN WinApi.S_OK
   END GetConnectionInterface;
   
   PROCEDURE (this: CConnectionPoint) GetConnectionPointContainer
                                             (OUT cpc: WinOle.IConnectionPointContainer): COM.RESULT;
   BEGIN
      RETURN this.obj.QueryInterface(COM.ID(cpc), cpc)
   END GetConnectionPointContainer;
   
   PROCEDURE (this: CConnectionPoint) Advise (sink: COM.IUnknown; OUT cookie: INTEGER): COM.RESULT;
      VAR res: COM.RESULT; unk: COM.IUnknown; i: INTEGER;
   BEGIN
      IF this.conn < connMax THEN
         res := sink.QueryInterface(this.iid, unk);
         IF res >= 0 THEN
            i := 0;
            WHILE this.unk[i] # NIL DO INC(i) END;
            this.unk[i] := unk;
            INC(this.next);
            this.cookies[i] := this.next;
            cookie := this.next;
            INC(this.conn);
            RETURN WinApi.S_OK
         ELSE RETURN WinApi.CONNECT_E_CANNOTCONNECT
         END
      ELSE RETURN WinApi.CONNECT_E_ADVISELIMIT
      END
   END Advise;
   
   PROCEDURE (this: CConnectionPoint) Unadvise (cookie: INTEGER): COM.RESULT;
      VAR i: INTEGER;
   BEGIN
      IF cookie # 0 THEN
         i := 0;
         WHILE (i < connMax) & (this.cookies[i] # cookie) DO INC(i) END;
         IF i < connMax THEN
            this.unk[i] := NIL;
            this.cookies[i] := 0;
            DEC(this.conn);
            RETURN WinApi.S_OK
         ELSE RETURN WinApi.CONNECT_E_NOCONNECTION
         END
      ELSE RETURN WinApi.E_INVALIDARG
      END
   END Unadvise;
   
   PROCEDURE (this: CConnectionPoint) EnumConnections (
                                             OUT enum: WinOle.IEnumConnections): COM.RESULT;
      VAR p: ARRAY connMax OF WinOle.CONNECTDATA; i, j: INTEGER; c: CEnumConnections;
   BEGIN
      IF this.conn > 0 THEN
         i := 0; j := 0;
         WHILE i < connMax DO
            IF this.unk[i] # NIL THEN
               p[j].pUnk := this.unk[i];
               p[j].dwCookie := this.cookies[i];
               INC(j)
            END;
            INC(i)
         END;
         CreateCEnumConnections(this.conn, p, c);
         IF c # NIL THEN
            enum := c;
            RETURN WinApi.S_OK
         ELSE RETURN WinApi.E_OUTOFMEMORY
         END
      ELSE RETURN WinApi.OLE_E_NOCONNECTION
      END
   END EnumConnections;
   
   
   (* ---------- CEnumConnectionPoints ---------- *)
   
   PROCEDURE CreateCEnumConnectionPoints (num: INTEGER; VAR data: ARRAY OF WinOle.IConnectionPoint;
                                                VAR new: CEnumConnectionPoints);
      VAR i: INTEGER;
   BEGIN
      NEW(new);
      IF new # NIL THEN
         new.cur := 0;
         new.num := num;
         i := 0;
         WHILE i < num DO new.data[i] := data[i]; INC(i) END
      END
   END CreateCEnumConnectionPoints;
   
   PROCEDURE (this: CEnumConnectionPoints) Next (num: INTEGER;
                                                      OUT elem: ARRAY [untagged] OF WinOle.IConnectionPoint;
                                                      OUT [nil] fetched: INTEGER): COM.RESULT;
      VAR n: INTEGER;
   BEGIN
      n := 0;
      IF VALID(fetched) THEN fetched := 0
      ELSIF num # 1 THEN RETURN WinApi.E_POINTER
      END;
      IF this.cur < this.num THEN
         WHILE (this.cur < this.num) & (num > 0) DO
            elem[n] := this.data[this.cur];
            INC(this.cur); INC(n); DEC(num)
         END;
         IF VALID(fetched) THEN fetched := n END;
         RETURN WinApi.S_OK
      END;
      RETURN WinApi.S_FALSE
   END Next;
   
   PROCEDURE (this: CEnumConnectionPoints) Skip (num: INTEGER): COM.RESULT;
   BEGIN
      IF this.cur + num < this.num THEN
         INC(this.cur, num); RETURN WinApi.S_OK
      ELSE RETURN WinApi.S_FALSE
      END
   END Skip;
   
   PROCEDURE (this: CEnumConnectionPoints) Reset (): COM.RESULT;
   BEGIN
      this.cur := 0; RETURN WinApi.S_OK
   END Reset;
   
   PROCEDURE (this: CEnumConnectionPoints) Clone (
                                                      OUT enum: WinOle.IEnumConnectionPoints): COM.RESULT;
      VAR new: CEnumConnectionPoints;
   BEGIN
      CreateCEnumConnectionPoints(this.num, this.data, new);
      IF new # NIL THEN
         new.cur := this.cur;
         enum := new;
         RETURN WinApi.S_OK
      ELSE RETURN WinApi.E_OUTOFMEMORY
      END
   END Clone;
   
   
   (* ---------- CConnObject ---------- *)
   
   PROCEDURE CreateCConnObject (VAR new: CConnObject);
      VAR i, n: INTEGER;
   BEGIN
      NEW(new);
      IF new # NIL THEN
         i := 0;
         WHILE i < connPoints DO
            CreateCConnectionPoint(new, COM.ID(IDuckEvents), new.connPt[i]);
            INC(i)
         END
      END
   END CreateCConnObject;
   
   PROCEDURE (this: CConnObject) EnumConnectionPoints
                                             (OUT enum: WinOle.IEnumConnectionPoints): COM.RESULT;
      VAR i: INTEGER; cp: ARRAY connPoints OF WinOle.IConnectionPoint; ce: CEnumConnectionPoints;
   BEGIN
      i := 0;
      WHILE i < connPoints DO cp[i] := this.connPt[i]; INC(i) END;
      CreateCEnumConnectionPoints(connPoints, cp, ce);
      IF ce # NIL THEN
         enum := ce;
         RETURN WinApi.S_OK
      ELSE RETURN WinApi.E_OUTOFMEMORY
      END
   END EnumConnectionPoints;
   
   PROCEDURE (this: CConnObject) FindConnectionPoint (IN iid: COM.GUID;
                                                         OUT conn: WinOle.IConnectionPoint): COM.RESULT;
      VAR
   BEGIN
      IF iid = COM.ID(IDuckEvents) THEN
         conn := this.connPt[0];
         RETURN WinApi.S_OK
      ELSE RETURN WinApi.E_NOINTERFACE
      END
   END FindConnectionPoint;
   
   PROCEDURE (this: CConnObject) TriggerEvent (event: INTEGER): BOOLEAN, NEW;
      VAR enum: WinOle.IEnumConnections; cd: ARRAY 1 OF WinOle.CONNECTDATA;
         duck: IDuckEvents; n: INTEGER;
   BEGIN
      IF this.connPt[0].EnumConnections(enum) >= 0 THEN
         WHILE enum.Next(1, cd, NIL) = WinApi.S_OK DO
            IF cd[0].pUnk.QueryInterface(COM.ID(duck), duck) >= 0 THEN
               CASE event OF
               | eventQuack: n := duck.Quack()
               | eventFlap: n := duck.Flap()
               | eventPaddle: n := duck.Paddle()
               END
            END
         END;
         RETURN TRUE
      ELSE RETURN FALSE
      END
   END TriggerEvent;
   

   (* ---------- commands ---------- *)
   
   PROCEDURE GetConnectionPoint (): WinOle.IConnectionPoint;
      VAR res: COM.RESULT; cont: WinOle.IConnectionPointContainer; cp: WinOle.IConnectionPoint;
   BEGIN
      res := obj.QueryInterface(COM.ID(cont), cont);
      IF res >= 0 THEN
         res := cont.FindConnectionPoint(COM.ID(IDuckEvents), cp);
         RETURN cp
      ELSE RETURN NIL
      END
   END GetConnectionPoint;
   
   PROCEDURE Connect (id: INTEGER);
      VAR cp: WinOle.IConnectionPoint; res: COM.RESULT;
   BEGIN
      IF obj # NIL THEN
         IF sink[id].cookie = 0 THEN
            cp := GetConnectionPoint();
            IF cp # NIL THEN
               res := cp.Advise(sink[id], sink[id].cookie);
               IF res < 0 THEN StdLog.String("Connection failed"); StdLog.Ln
               ELSE StdLog.String("Connection complete"); StdLog.Ln
               END
            ELSE
               StdLog.String("Failed to get IConnectionPoint"); StdLog.Ln
            END
         ELSE
            StdLog.String("Sink already connected"); StdLog.Ln
         END
      ELSE
         StdLog.String("No object"); StdLog.Ln
      END
   END Connect;
   
   PROCEDURE Disconnect (id: INTEGER);
      VAR cp: WinOle.IConnectionPoint; res: COM.RESULT;
   BEGIN
      IF obj # NIL THEN
         IF sink[id].cookie # 0 THEN
            cp := GetConnectionPoint();
            IF cp # NIL THEN
               res := cp.Unadvise(sink[id].cookie);
               IF res < 0 THEN StdLog.String("Disconnection failed"); StdLog.Ln
               ELSE
                  StdLog.String("Disconnection complete"); StdLog.Ln;
                  sink[id].cookie := 0
               END
            ELSE
               StdLog.String("Failed to get IConnectionPoint"); StdLog.Ln
            END
         ELSE
            StdLog.String("Sink not connected"); StdLog.Ln
         END
      ELSE
         StdLog.String("No object"); StdLog.Ln
      END
   END Disconnect;
   
   PROCEDURE Init*;
   BEGIN
      CreateCDuckEvents(SINK1, sink[SINK1]);
      CreateCDuckEvents(SINK2, sink[SINK2]);
   END Init;
   
   PROCEDURE Release*;
   BEGIN
      obj := NIL;
      Disconnect(SINK1);
      Disconnect(SINK2);
      sink[SINK1] := NIL;
      sink[SINK2] := NIL
   END Release;
   PROCEDURE ObjectCreate*;

   BEGIN
      CreateCConnObject(obj);
      IF obj # NIL THEN
         StdLog.String(" Object created"); StdLog.Ln
      END
   END ObjectCreate;
   
   PROCEDURE ObjectRelease*;
   BEGIN
      IF obj # NIL THEN
         obj := NIL;
         StdLog.String("Object released"); StdLog.Ln
      ELSE
         StdLog.String("No object"); StdLog.Ln
      END
   END ObjectRelease;
   
   PROCEDURE Sink1Connect*;
   BEGIN
      Connect(SINK1)
   END Sink1Connect;
   
   PROCEDURE Sink1Disconnect*;
   BEGIN
      Disconnect(SINK1)
   END Sink1Disconnect;
   
   PROCEDURE Sink2Connect*;
   BEGIN
      Connect(SINK2)
   END Sink2Connect;
   
   PROCEDURE Sink2Disconnect*;
   BEGIN
      Disconnect(SINK2)
   END Sink2Disconnect;
   
   PROCEDURE TriggerQuack*;
   BEGIN
      IF obj # NIL THEN
         IF ~obj.TriggerEvent(eventQuack) THEN
            StdLog.String("No connected sinks"); StdLog.Ln
         END
      ELSE
         StdLog.String("No object"); StdLog.Ln
      END
   END TriggerQuack;
   
   PROCEDURE TriggerFlap*;
   BEGIN
      IF obj # NIL THEN
         IF ~obj.TriggerEvent(eventFlap) THEN
            StdLog.String("No connected sinks"); StdLog.Ln
         END
      ELSE
         StdLog.String("No object"); StdLog.Ln
      END
   END TriggerFlap;
   
   PROCEDURE TriggerPaddle*;
   BEGIN
      IF obj # NIL THEN
         IF ~obj.TriggerEvent(eventPaddle) THEN
            StdLog.String("No connected sinks"); StdLog.Ln
         END
      ELSE
         StdLog.String("No object"); StdLog.Ln
      END
   END TriggerPaddle;
   
END ComConnect.
ComConnect.Init


ComConnect.Release
ComConnect.ObjectCreate

ComConnect.ObjectRelease
ComConnect.Sink1Connect

ComConnect.Sink1Disconnect
ComConnect.Sink2Connect
ComConnect.Sink2Disconnect
ComConnect.TriggerFlap

ComConnect.TriggerPaddle
ComConnect.TriggerQuack