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	= "
	- YYYYMMDD, nn, ...
	"
	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
