Event aggregator - cast object to interface

How to find out if object supports IHandle<T> and is there any possible workaround to achieve this in delphi (2010, XE)? Also has anybody seen a nice implementation of event aggregator for delphi?

IHandle<TMessage> = interface
 procedure Handle(AMessage: TMessage);
end;

EventAggregator = class
private
 FSubscribers: TList<TObject>;
public
 constructor Create;
 destructor Destroy; override;
 procedure Subscribe(AInstance: TObject);
 procedure Unsubscribe(AInstance: TObject);
 procedure Publish<T>(AMessage: T);
end;

procedure EventAggregator.Publish<T>(AMessage: T);
var
  LReference: TObject;
  LTarget: IHandle<T>;
begin
    for LReference in FS开发者_运维技巧ubscribers do
    begin
      LTarget:= LReference as IHandle<T>; // <-- Wish this would work
      if Assigned(LTarget) then
        LTarget.Handle(AMessage);
    end;
end;

procedure EventAggregator.Subscribe(AInstance: TObject);
begin
 FSubscribers.Add(AInstance);
end;

procedure EventAggregator.Unsubscribe(AInstance: TObject);
begin
 FSubscribers.Remove(AInstance)
end;

Update

I would like to point out the excellent article "Generic Interfaces in Delphi" by Malcolm Groves link

which describes exactly what I would like to achieve.

I think, a possible workaround is to use a non-generic interface with GUID:

IMessageHandler = interface
  ['...']
  procedure Handle(const AMessage: TValue);
end;

To be able to check if an instance implements a given interface, that interface needs to have a defined GUID. So, add a guid to your interface (you'll also need this guid in a const or variable so you may refernce it later in code):

const
  IID_Handle: TGUID = '{0D3599E1-2E1B-4BC1-ABC9-B654817EC6F1}';

type
  IHandle<TMessage> = interface
    ['{0D3599E1-2E1B-4BC1-ABC9-B654817EC6F1}']
    procedure Handle(AMessage: TMessage);
  end;

(You shouldn't use my guid, it's just an example.. press ctrl+shift+G to generate a new guid in the IDE).

Then check to see if the registered subscriber supports this interface:

//      LTarget:= LReference as IHandle; // <-- Wish this would work
      if Supports(LReference, IID_Handle, LTarget) then
        LTarget.Handle(AMessage);

However, this doesn't take the generic part of the interface into account, it only checks the GUID.

So you'll need some more logic around this to check if the target actually supports the message type.

Also, since you're dealing with classes that will be implementing an interface, and thus should derive from TInterfacedObject (or a compatible interface to that class) you should keep all references to the created object in interface variables, thus change the subscrber list from a reference to TObjects' to one of IInterfaces'. And there is a specific class for that, too:

FSubscribers: TInterfaceList;

Of course, you'll have to change the signature to the subscribe/unsubscribe functions too:

procedure Subscribe(AInstance: IInterface);
procedure Unsubscribe(AInstance: IInterface);

I think a better way would be to take out the generic of the IHandle interface. That way you can enforce that all subscribers implement the basic IHandler interface by changing the subscribe/unsibscribe signature to take IHandler instead of IInterface.

IHandler can then hold the functionality required to determine if the subscriber supports the given message type or not.

This will be left as an excercise to the reader. You might want to start with my little test app (D2010) which you can download from My Test App.

N.B. The test app explores the possibility of using generics in the interface, and will most likely crash when publishing events. Use the debugger to single step to see what happens. I doesn't crash when publishing integer 0, which seems to work. The reason is that both Int and String handler will be called regardless of input type to Publish (as discussed earlier).

Another approach would be to skip interfaces altogheter and go with the dispatch functionality of TObject.

We need a message record for this:

  TMessage = record
    MessageId: Word;
    Value: TValue;
  end;

as well as some event ID's:

const
  EVENT_BASE = WM_USER;
  MY_EVENT = EVENT_BASE;
  OTHER_EVENT = MY_EVENT + 1;

and update the publish routine:

procedure TEventAggregator.Publish<T>(MsgId: Word; const Value: T);
var
  LReference: TObject;
  Msg: TMessage;
begin
  Msg.MessageId := MsgId;
  Msg.Value := TValue.From(Value);

  for LReference in FSubscribers do begin
    LReference.Dispatch(Msg);
  end;
end;

Then ANY object may be a subscriber to events. To handle a event, the handler only needs to specify which event id to handle (or catch it in the DefaultHandler).

To handle the MY_EVENT message, simply add this to a class:

procedure HandleMyEvent(var Msg: TMessage); message MY_EVENT;

See also the example on dispatch from the delphi documentation: TObjectDispatch

This way we can publish messages and let the subscriber pick and choose which ones to handle. Also, the type can be determined in the handler. Also, one might declare (in documentation, not code) that a given event id should be of a given type, so the event handler for MY_EVENT could simply access the value as Msg.Value.AsInteger.

N.B. The message is passed as var, so it may get modified by the subscribers. If this is not acceptable, the Msg record must be reinitialized before each dispatch.

Working prototype. Not tested in production!

unit zEventAggregator;

interface

uses
  Classes, TypInfo, SysUtils, Generics.Collections;

type
  /// <summary>
  /// Denotes a class which can handle a particular type of message.
  /// </summary>
  /// <typeparam name="TMessage">The type of message to handle.</typeparam>
  IHandle<TMessage> = interface
    /// <summary>
    /// Handles the message.
    /// </summary>
    /// <param name="message">The message.</param>
    procedure Handle(AMessage: TMessage);
  end;

  /// <summary>
  /// Subscription token
  /// </summary>
  ISubscription = interface
    ['{3A557B05-286B-4B86-BDD4-9AC44E8389CF}']
    procedure Dispose;
    function GetSubscriptionType: string;
    property SubscriptionType: string read GetSubscriptionType;
  end;

  TSubscriber<T> = class(TInterfacedObject, ISubscription)
  strict private
    FAction: TProc<T>;
    FDisposed: Boolean;
    FHandle: IHandle<T>;
    FOwner: TList < TSubscriber < T >> ;
  public
    constructor Create(AOwner: TList < TSubscriber < T >> ; AAction: TProc<T>; AHandle: IHandle<T>);
    destructor Destroy; override;
    procedure Dispose;
    procedure Publish(AMessage: T);
    function GetSubscriptionType: string;
  end;

  TEventBroker<T> = class
  strict private
    FSubscribers: TList < TSubscriber < T >> ;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Publish(AMessage: T);
    function Subscribe(AAction: IHandle<T>): ISubscription; overload;
    function Subscribe(AAction: TProc<T>): ISubscription; overload;
  end;

  TBaseEventAggregator = class
  strict protected
    FEventBrokers: TObjectDictionary<PTypeInfo, TObject>;
  public
    constructor Create;
    destructor Destroy; override;
    function GetEvent<TMessage>: TEventBroker<TMessage>;
  end;

  /// <summary>
  /// Enables loosely-coupled publication of and subscription to events.
  /// </summary>
  TEventAggregator = class(TBaseEventAggregator)
  public
    /// <summary>
    /// Publishes a message.
    /// </summary>
    /// <typeparam name="T">The type of message being published.</typeparam>
    /// <param name="message">The message instance.</param>
    procedure Publish<TMessage>(AMessage: TMessage);
    /// <summary>
    /// Subscribes an instance class handler IHandle<TMessage> to all events of type TMessage/>
    /// </summary>
    function Subscribe<TMessage>(AAction: IHandle<TMessage>): ISubscription; overload;
    /// <summary>
    /// Subscribes a method to all events of type TMessage/>
    /// </summary>
    function Subscribe<TMessage>(AAction: TProc<TMessage>): ISubscription; overload;
  end;

implementation

{ TSubscriber<T> }

constructor TSubscriber<T>.Create(AOwner: TList < TSubscriber < T >> ; AAction: TProc<T>; AHandle: IHandle<T>);
begin
  FAction := AAction;
  FDisposed := False;
  FHandle := AHandle;
  FOwner := AOwner;
end;

destructor TSubscriber<T>.Destroy;
begin
  Dispose;
  inherited;
end;

procedure TSubscriber<T>.Dispose;
begin
  if not FDisposed then
  begin
    TMonitor.Enter(Self);
    try
      if not FDisposed then
      begin
        FAction := nil;
        FHandle := nil;
        FOwner.Remove(Self);
        FDisposed := true;
      end;
    finally
      TMonitor.Exit(Self);
    end;
  end;
end;

function TSubscriber<T>.GetSubscriptionType: string;
begin
  Result:= GetTypeName(TypeInfo(T));
end;

procedure TSubscriber<T>.Publish(AMessage: T);
var
  a: TProc<T>;
begin
  if Assigned(FAction) then
    TProc<T>(FAction)(AMessage)
  else if Assigned(FHandle) then
    FHandle.Handle(AMessage);
end;

{ TEventBroker<T> }

constructor TEventBroker<T>.Create;
begin
  FSubscribers := TList < TSubscriber < T >> .Create;
end;

destructor TEventBroker<T>.Destroy;
begin
  FreeAndNil(FSubscribers);
  inherited;
end;

procedure TEventBroker<T>.Publish(AMessage: T);
var
  LTarget: TSubscriber<T>;
begin
  TMonitor.Enter(Self);
  try
    for LTarget in FSubscribers do
    begin
      LTarget.Publish(AMessage);
    end;
  finally
    TMonitor.Exit(Self);
  end;
end;

function TEventBroker<T>.Subscribe(AAction: IHandle<T>): ISubscription;
var
  LSubscriber: TSubscriber<T>;
begin
  TMonitor.Enter(Self);
  try
    LSubscriber := TSubscriber<T>.Create(FSubscribers, nil, AAction);
    FSubscribers.Add(LSubscriber);
    Result := LSubscriber;
  finally
    TMonitor.Exit(Self);
  end;
end;

function TEventBroker<T>.Subscribe(AAction: TProc<T>): ISubscription;
var
  LSubscriber: TSubscriber<T>;
begin
  TMonitor.Enter(Self);
  try
    LSubscriber := TSubscriber<T>.Create(FSubscribers, AAction, nil);
    FSubscribers.Add(LSubscriber);
    Result := LSubscriber;
  finally
    TMonitor.Exit(Self);
  end;
end;

{ TBaseEventAggregator }

constructor TBaseEventAggregator.Create;
begin
  FEventBrokers := TObjectDictionary<PTypeInfo, TObject>.Create([doOwnsValues]);
end;

destructor TBaseEventAggregator.Destroy;
begin
  FreeAndNil(FEventBrokers);
  inherited;
end;

function TBaseEventAggregator.GetEvent<TMessage>: TEventBroker<TMessage>;
var
  LEventBroker: TObject;
  LEventType: PTypeInfo;
  s: string;
begin
  LEventType := TypeInfo(TMessage);
  s:= GetTypeName(LEventType);

  if not FEventBrokers.TryGetValue(LEventType, LEventBroker) then
  begin
    TMonitor.Enter(Self);
    try
      if not FEventBrokers.TryGetValue(LEventType, LEventBroker) then
      begin
        LEventBroker := TEventBroker<TMessage>.Create;
        FEventBrokers.Add(LEventType, LEventBroker);
      end;
    finally
      TMonitor.Exit(Self);
    end;
  end;

  Result := TEventBroker<TMessage>(LEventBroker);
end;

{ TEventAggregator }

procedure TEventAggregator.Publish<TMessage>(AMessage: TMessage);
begin
  GetEvent<TMessage>.Publish(AMessage);
end;

function TEventAggregator.Subscribe<TMessage>(AAction: IHandle<TMessage>): ISubscription;
begin
  Result := GetEvent<TMessage>.Subscribe(AAction);
end;

function TEventAggregator.Subscribe<TMessage>(AAction: TProc<TMessage>): ISubscription;
begin
  Result := GetEvent<TMessage>.Subscribe(AAction);
end;

end.

Comments?

Open this url and grab the zip file http://qc.embarcadero.com/wc/qcmain.aspx?d=91796