Delphi - how to use supports with a common GUID?

Question

(code below)

I am writing an event bus with Delphi and the Spring4d library.

I was inspired by the Spring4d Library (Event Based Architecture) Samples

In principle, the event bus

• Allows you to add subscribers to it
• Allows you to send events to subscribers

I'm interested in the method subscribe

TEventBus.subscribe(aHandler : TInterfacedObject; aEvtGuid : TGUID);

I'm having trouble finding out if this handler supports the IEventHandler interface:

TMyClass = class(TInterfacedObject, IEventHandler<IMyEvent>) // ...
TMyOtherClass = class(TInterfacedObject, IEventHandler<IMyOtherEvent>) // ...

aEvtBus.subscribe(aMyClass, IMyEvent) // ok
aEvtBus.subscribe(aMyOtherClass, IMyOtherEvent) // ok
aEvtBus.subscribe(aMyOtherClass, IMyEvent) // should fail
aEvtBus.subscribe(aMyClass, IMyOtherEvent) // should fail

I am trying to check if the aHandlerinterface supports IEventHandler<aEvtGUid>when it tries to subscribe to this event.

Now I have found the RttiInterfaceType matching IEventHandler.

lRttiHandlerType := TType.FindType('IEventHandler<' + lRttiEventIntfType.QualifiedName + '>');
lRttiHandlerIntfType := TRttiInterfaceType(lRttiHandlerType);

Then I thought about using

SysUtils.Supports(aHandler, lRttiHandlerIntfType.GUID);

The problem is that RttiInterfaceType.GUID always points to

{97797738-9DB8-4748-92AA-355031294954}

GUID IEventHandler<T : IEvent> (. ). true, aHandler IEventHandler<T : IEvent>.

, IEventHandler<aEvtGUid>, aEvtGuid - GUID, RttiInterfaceType ?

1

  lValue := TValue.From<TInterfacedObject>(aListener);
  lValue.TryCast( lRttiHandlerIntfType.Handle, lValueCast );

true.

---

unit Unit1;


interface


uses
  Spring.Collections,
  Spring.Collections.Lists;


type

  { Event Definitions }

  IEvent = interface(IInterface)
    ['{45434EEC-6125-4349-A673-5077DE6F54C9}']
  End;

  IMyEvent = interface(IEvent)
    ['{C5B07E59-4459-46CF-91CC-4F9706255FCC}']
  end;

  IMyOtherEvent = interface(IEvent)
    ['{8C31AF25-711C-403E-B424-8193696DDE46}']
  end;

  TEvent = class(TInterfacedObject, IEvent);

  TMyEvent = class(TEvent, IMyEvent);

  TMyOtherEvent = class(TEvent, IMyOtherEvent);

  { Event handlers }

  IEventHandler<T: IEvent> = interface(IInterface)
    ['{97797738-9DB8-4748-92AA-355031294954}']
    procedure Handle(aEvent: T);
  end;

  IEventHandler = interface(IEventHandler<IEvent>)
    ['{C3699410-A64A-4C9F-8D87-D95841AD044C}']
  end;

  { Classes that handle events }

  TMyClass = class(TInterfacedObject, IEventHandler<IMyEvent>)
    procedure Handle(aEvent: IMyEvent);
  end;

  TMyOtherClass = class(TInterfacedObject, IEventHandler<IMyOtherEvent>)
    procedure Handle(aEvent: IMyOtherEvent);
  end;

  { Event Bus }

  TEventBus = class
  private
    fSuscribers: IDictionary<TGUID, IList<TObject>>;

  public
    constructor Create;
    procedure Suscribe(
      aListener : TInterfacedObject;
      aEventType: TGUID);
    procedure Dispatch<T: IEvent>(aEvent: T);
    procedure Test;
  end;


implementation


uses
  VCL.Dialogs,
  Rtti,
  Spring.Reflection,
  SysUtils;

procedure TMyClass.Handle(aEvent: IMyEvent);
begin
  ShowMessage('MyClass handle IMyEvent');
end;

{ TMyOtherClass }

procedure TMyOtherClass.Handle(aEvent: IMyOtherEvent);
begin
  ShowMessage('MyOtherClass handle IMyOtherEvent');
end;

constructor TEventBus.Create;
begin
  inherited;
  fSuscribers := TCollections.CreateDictionary<TGUID, IList<TObject>>;;
end;

procedure TEventBus.Dispatch<T>(aEvent: T);
begin
  //
end;

procedure TEventBus.Suscribe(aListener : TInterfacedObject; aEventType: TGUID);
var
  lRttiContext                            : TRttiContext;
  lRttiHandlerType                        : TRttiType;
  lEventHandlerIntfName                   : string;
  lRttiEventIntfType, lRttiHandlerIntfType: TRttiInterfaceType;
  aSuscriberList                          : IList<TObject>;
begin

  if not TType.TryGetInterfaceType(aEventType, lRttiEventIntfType) then
    raise Exception.Create('Impossible to find event type');

  lRttiHandlerType := TType.FindType('IEventHandler<' + lRttiEventIntfType.QualifiedName + '>');

  if lRttiHandlerType = nil then
    raise Exception.Create('Impossible to find handler type');

  if not (lRttiHandlerType.TypeKind = TTypeKind.tkInterface) then
    raise Exception.Create('Handler type is not interface');

  lRttiHandlerIntfType := TRttiInterfaceType(lRttiHandlerType);

  if not Supports(aListener, lRttiHandlerIntfType.GUID) then
    raise Exception.CreateFmt('Subscriber does not support interface %s with guid %s', [lRttiHandlerIntfType.QualifiedName, GUIDToString(lRttiHandlerIntfType.GUID)]);

  if not fSuscribers.ContainsKey(aEventType) then
    fSuscribers.Add(aEventType, TCollections.CreateList<TObject>);

  aSuscriberList := fSuscribers.Items[aEventType];

  if not aSuscriberList.Contains(aListener) then
    aSuscriberList.Add(aListener);


end;


procedure TEventBus.Test;
var
  aObj1 : TMyClass;
  aObj2 : TMyOtherClass;
begin

  aObj1 := TMyClass.Create;
  aObj2 := TMyOtherClass.Create;

  Suscribe(aObj1, IMyEvent);
  Suscribe(aObj2, IMyOtherEvent);

  try
    Suscribe(aObj1, IMyOtherEvent);
    raise Exception.Create('Should not be there');
  except on E: Exception do
    ShowMessage(E.Message);
  end;



end;

end.

Answer 1

:

type
  THelper = class helper for TObject
    class function SupportsEventHandler<T: IEvent>: Boolean;
  end;

function GetInterfaceTypeInfo(InterfaceTable: PInterfaceTable): PTypeInfo;
var
  P: PPointer;
begin
  if Assigned(InterfaceTable) and (InterfaceTable^.EntryCount > 0) then
  begin
    P := Pointer(NativeUInt(@InterfaceTable^.Entries[InterfaceTable^.EntryCount]));
    Result := Pointer(NativeUInt(P^) + SizeOf(Pointer));
  end
  else
    Result := nil;
end;

class function THelper.SupportsEventHandler<T>: Boolean;
var
  InterfaceTable: PInterfaceTable;
  IntfTypeInfo: PTypeInfo;
  I: Integer;
begin
  Result := False;

  InterfaceTable := TMyClass.GetInterfaceTable;
  IntfTypeInfo := GetInterfaceTypeInfo(InterfaceTable);
  for I := 0 to InterfaceTable^.EntryCount - 1 do
  begin
    if IsEqualGUID(InterfaceTable^.Entries[I].IID, IEventHandler<IEvent>) and (IntfTypeInfo = TypeInfo(IEventHandler<T>)) then
    begin
      Result := True;
      Break;
    end;

    Inc(IntfTypeInfo);
  end;
end;

:

var
  Handler: IInterface;
begin
  Handler := TMyClass.Create;

  if (Handler as TObject).SupportsEventHandler<IMyEvent> then
    Writeln('IMyEvent: Yes')
  else
    Writeln('IMyEvent: No');

  if (Handler as TObject).SupportsEventHandler<IMyOtherEvent> then
    Writeln('IMyOtherEvent: Yes')
  else
    Writeln('IMyOtherEvent: No');
end;