利用RTTI实现Delphi的多播事件代理研究

我们知道Delphi的每个对象可以包含多个Property，Property中可以是方法，例如TButton.OnClick属性。Delphi提供的仅仅是

一对一的设置，无法直接让TButton.OnClick去调用多个方法，而Java中采用Listener模式有类似AddListener方法提供多播。

Delphi多播的思想源于Allen Bauer的Blog：http://blogs.embarcadero.com/abauer/2008/08/15/38865，

cnWizard的武稀松大侠在此思想基础上实现了Win32的Delphi多播机制见：http://www.raysoftware.cn/?p=44#comment-2442，并且应用于cnWizard;

开源项目DSharp实现了更加完整的多播机制，可提供基于接口的多播，见：https://bitbucket.org/sglienke/dsharp

本人希望借鉴前人的基础上，实现一个对象的事件多播代理，即TEventAgent是一个TObject的事件多播代理器，将一个TObject传给TEventAgent后， TEventAgent扫描TObject所有事件，并为每个事件提供多播功能。

下面程序是一个简单示例，引用了 DSharp.Core.Events.pas单元，并在Delphi XE3 测试成功.

 unit utObjEventAgent;

 interface

 uses System.Generics.Collections, DSharp.Core.Events, System.TypInfo, Classes;

 type
   TEventLinker=class(DSharp.Core.Events.TEvent)     //单个事件的多播器
   protected
     FLinkedObject: TObject;
     FLinkedProperty: PPropInfo;
     FOriginal:TMethod;

     FEventTypeData:PTypeData;
     FEventName:String;
     procedure MethodAdded(const Method: TMethod); override;
     procedure MethodRemoved(const Method: TMethod); override;
     procedure Notify(Sender: TObject; const Item: TMethod;
       Action: System.Generics.Collections.TCollectionNotification); override;
     property Owner;
     property RefCount;
   public
     constructor Create(LinkedObj:TObject; LinkedPrpt:PPropInfo);
     destructor Destroy; override;
   end;

   TEventAgent=class                 //对象的事件多播代理
     protected
       FOwner:TObject;
       FPropList: PPropList;
       FNameList:TDictionary<String, TEventLinker>;
       procedure Prepare; virtual;
       procedure Clear;
     public
       constructor Create(aOwner:TObject); virtual;
       destructor Destroy;override;
       function GetEventCount: Int32;
       function GetEventName(Index: Int32): PWideChar;
       procedure AddEventNotifier(EventName: String; const NotifierMethod: TMethod);overload;    // 添加事件处理函数
       procedure RemoveEventNotifier(EventName: String; const NotifierMethod: TMethod);overload; // 移除时间处理函数
   end;

 implementation

 uses System.Rtti;

 { TEventLinker }

 constructor TEventLinker.Create(LinkedObj:TObject; LinkedPrpt:PPropInfo);
 begin
   inherited Create(LinkedPrpt.PropType^, nil);
   FLinkedObject:=LinkedObj;
   FLinkedProperty:=LinkedPrpt;
   FEventName:=FLinkedProperty^.Name;
   FOriginal:=GetMethodProp(FLinkedObject, FLinkedProperty);
   SetMethodProp(FLinkedObject, FLinkedProperty, Self.GetInvoke);
   if Assigned(FOriginal.Data) and Assigned(FOriginal.Code) then Add(FOriginal);  //将原事件方法加入多播列表
 end;

 destructor TEventLinker.Destroy;
 begin
   SetMethodProp(FLinkedObject, FLinkedProperty, FOriginal);
   inherited;
 end;

 procedure TEventLinker.MethodAdded(const Method: TMethod);
 begin
 end;

 procedure TEventLinker.MethodRemoved(const Method: TMethod);
 begin
 end;

 procedure TEventLinker.Notify(Sender: TObject; const Item: TMethod;
   Action: System.Generics.Collections.TCollectionNotification);
 begin
 end;

 { TEventAgent }

 procedure TEventAgent.AddEventNotifier(EventName: String;
   const NotifierMethod: TMethod);
 var
   V:TEventLinker;
 begin
   if FNameList.TryGetValue(EventName, V) then
   begin
     if V.IndexOf(NotifierMethod)< then
       V.Add(NotifierMethod);
   end;
 end;

 procedure TEventAgent.Clear;
   var
     Item: TPair<String, TEventLinker>;
   begin
     for Item in FNameList do
       Item.Value.Free;
     FNameList.Clear;
     if Assigned(FPropList) then FreeMem(FPropList);
   end;

 constructor TEventAgent.Create(aOwner:TObject);
 begin
   inherited Create;
   FNameList:=TDictionary<String, TEventLinker>.Create;
   FOwner:=aOwner;
   Prepare;
 end;

 destructor TEventAgent.Destroy;
 begin
   Clear;
   FNameList.Free;
   inherited;
 end;

 function TEventAgent.GetEventCount: Int32;
 begin
   Result:=FNameList.Count;
 end;

 function TEventAgent.GetEventName(Index: Int32): PWideChar;
 begin
   Result:=PWideChar(FNameList.Keys.ToArray[Index]);
 end;

 procedure TEventAgent.Prepare;
 var
   N, i:Integer;
   Linker:TEventLinker;
   Context: TRttiContext;
 begin
   Clear;
   N:=GetPropList(FOwner.ClassInfo, FPropList);
   for i :=  to N- do
     if FPropList^[i].PropType^.Kind = tkMethod then
   begin
     if FPropList[i].GetProc=nil then Continue;
     Linker:=TEventLinker.Create(FOwner, FPropList[i]);
     Linker.FEventName:=FPropList[i].Name;
     FNameList.Add(Linker.FEventName, Linker);
   end;
 end;

 procedure TEventAgent.RemoveEventNotifier(EventName: String;
   const NotifierMethod: TMethod);
 var
   V:TEventLinker;
 begin
   if FNameList.TryGetValue(EventName, V) then
   begin
     V.Remove(NotifierMethod);
   end;
 end;

 end.

测试程序演示一个TButton被事件多播代理，其OnClick,OnMouseDown均有3个多播方法。
测试程序：

 unit Unit1;

 interface

 uses
   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, utObjEventAgent, DSharp.Core.Events, ObjAuto,
   Vcl.StdCtrls;

 type
   TForm1 = class(TForm)
     Button1: TButton;
     Memo1: TMemo;
     procedure FormCreate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   private
     { Private declarations }
     procedure OnClick1(Sender:TObject);
     procedure OnClick2(Sender:TObject);
     procedure Button1MouseDown1(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure Button1MouseDown2(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   public
     { Public declarations }
     FAgent:TEventAgent;
   end;

 var
   Form1: TForm1;

 implementation

 uses System.Rtti;

 {$R *.dfm}

 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Memo1.Lines.Add('Button1Click');
 end;

 procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   Memo1.Lines.Add(Format('Clicked at (%d, %d)', [X, Y]));
 end;

 procedure TForm1.Button1MouseDown1(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   Memo1.Lines.Add('Button1MouseDown1')
 end;

 procedure TForm1.Button1MouseDown2(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   Memo1.Lines.Add('Button1MouseDown2')
 end;

 procedure TForm1.FormCreate(Sender: TObject);
 var
   V:TNotifyEvent;
   M:TMouseEvent;
 begin
   FAgent:=TEventAgent.Create(Button1);
   V:= Self.OnClick1;
   FAgent.AddEventNotifier('OnClick', TMethod(V));
   V:= Self.OnClick2;
   FAgent.AddEventNotifier('OnClick', TMethod(V));
   M:= Self.Button1MouseDown1;
   FAgent.AddEventNotifier('OnMouseDown', TMethod(M));
   M:= Self.Button1MouseDown2;
   FAgent.AddEventNotifier('OnMouseDown', TMethod(M));
 end;

 procedure TForm1.OnClick1(Sender: TObject);
 begin
   Memo1.Lines.Add('OnClick1');
 end;

 procedure TForm1.OnClick2(Sender: TObject);
 begin
   Memo1.Lines.Add('OnClick2');
 end;

 end.

测试程序dfm文件

 object Form1: TForm1
   Left =
   Top =
   Caption = 'Form1'
   ClientHeight =
   ClientWidth =
   OnCreate = FormCreate
   object Button1: TButton
     Left =
     Top =
     Width =
     Height =
     Caption = 'Button1'
     OnClick = Button1Click
     OnMouseDown = Button1MouseDown
   end
   object Memo1: TMemo
     Left =
     Top =
     Width =
     Height =
     Lines.Strings = (
       'Memo1')
   end
 end

我的多播代理机制原理是，将所代理对象的所有事件指向代理器对应的函数，由此函数再以此调用多个回调函数。
1.当所代理事件没有任何事件回调时，多播代理不会修改事件函数指针，原对象此事件回调仍然为nil，
2.当所代理事件已经有事件回调函数指针，多播代理会将自己替换原函数指针，并且将原函数指针加入多播列表中.

我的多播机制有如下特点：
1.兼容Delphi的事件回调机制，因此对于老的程序，不用怎么修改，就能被回调多个函数，实现多播。
2.此多播机制不限于界面对象，可代理任何对象，只要此对象有放入public或published的事件property属性，均被自动代理，无所谓其传入的参数是什么类型及有多少个。
3.用户的对象如果需要多播功能，仅需要按照单个事件模式设计即可，多播代理自动帮他实现多播。

再举例1：
比如我们网络通讯假设用的是TTcpClient，从服务器接收数据。接收来的数据进行处理，处理过程有很多，比如有的模块需要存盘到文件，有的处理模块进行数据转发，有的模块需要进行解码分析。
如果使用多播，则可以简单的方法实现。

假如原来的网络程序仅实现了数据存储功能，需要增加解码处理功能，我们不需要修改原来的程序，增加解码模块即可：

1.新建一个DataModule, 放上一个TTcpClient，设置要连接的服务器端口地址

unit Unit2;

interface

uses
  System.SysUtils, System.Classes, Web.Win.Sockets, utObjEventAgent;

type
  TDataModule2 = class(TDataModule)
    TcpClient1: TTcpClient;
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    FLink:TEventAgent;
  end;

var
  DataModule2: TDataModule2;

implementation

{%CLASSGROUP 'Vcl.Controls.TControl'}

{$R *.dfm}

procedure TDataModule2.DataModuleCreate(Sender: TObject);
begin
  FLink:=TEventAgent.Create(TcpClient1);
  TcpClient1.Active:=True;
end;
procedure TDataModule2.DataModuleDestroy(Sender: TObject);
begin
  FLink.Free;
end;
end.

　　

2.接着，只需在不同的模块去接收你的数据，例如数据存储模块：

unit Unit3;

interface

uses utObjEventAgent, Unit2, Classes, Web.Win.Sockets;

type
  TPersistModule=class
  protected
    FStream:TFileStream;
  private
    procedure OnDataReceive(Sender: TObject; Buf: PAnsiChar; var DataLen: Integer);
  public
    constructor Create;
    destructor Destroy;override;
  end;
implementation

{ TPersistModule }

constructor TPersistModule.Create;
var
   V:TSocketDataEvent;
begin
  inherited Create;
  FStream:=TFileStream.Create('C:\test.dat', fmCreate);
  V:= Self.OnDataReceive;
  DataModule2.FLink.AddEventNotifier('OnReceive', TMethod(V));
end;

destructor TPersistModule.Destroy;
var
   V:TSocketDataEvent;
begin
  V:= Self.OnDataReceive;
  DataModule2.FLink.RemoveEventNotifier('OnReceive', TMethod(V));
  FStream.Free;
  inherited;
end;

procedure TPersistModule.OnDataReceive(Sender: TObject; Buf: PAnsiChar;
  var DataLen: Integer);
begin
  FStream.Write(Buf^, DataLen);
end;

end.

　　

3.数据解码模块

unit Unit4;

interface

uses utObjEventAgent, Unit2, Classes, Web.Win.Sockets, utDecoder;

type
  TDecodeModule=class
  protected
    FDecoder:TDecoder;
  private
    procedure OnData(Sender: TObject; Buf: PAnsiChar; var DataLen: Integer);
  public
    constructor Create;
    destructor Destroy;override;
  end;
implementation

{ TDecodeModule }

constructor TDecodeModule.Create;
var
  V:TSocketDataEvent;
begin
  inherited Create;
  FDecoder:=TDecoder.Create
  V:= Self.OnData;
  DataModule2.FLink.AddEventNotifier('OnReceive', TMethod(V));
end;

destructor TDecodeModule.Destroy;
var
  V:TSocketDataEvent;
begin
  V:= Self.OnData;
  DataModule2.FLink.RemoveEventNotifier('OnReceive', TMethod(V));
  Fdecoder.Free;

  inherited;
end;

procedure TDecodeModule.OnData(Sender: TObject; Buf: PAnsiChar;
  var DataLen: Integer);
begin
  FDecoder.Decode(Pointer(Buf), DataLen);
end;

end.

　　

再举例2：

借用 “Delphi 实现事件侦听与触发”的例子：

const
  evtDataChanged = 'evtDataChanged';

  //数据处理类, 用于提供数据
  TOnData=procedure( Name, City, CellPhone:String; Age: Integer ) of Object;
  TNwDataClass = class( TObject)
  private
   FOnData:TOnData;
  public
    Link:TEventAgent;
    constructor Create;
    destructor Destroy;override;
    procedure AddData( Name, City, CellPhone:String; Age: Integer );
   property OnData:TOnData read FOnData write FOnData;
  end;

  //界面显示类
  TNwInterface = class( TForm )
    procedure FormCreate( Sender: TObject );
    procedure FormDestroy( Sender: TObject );
  protected
    procedure OnEvent( Name, City, CellPhone:String; Age: Integer );
    procedure OnEvent2( Name, City, CellPhone:String; Age: Integer );
  public
    procedure AddDataToList(  Name, City, CellPhone:String; Age: Integer);
    procedure AddDataToFile( Name, City, CellPhone:String; Age: Integer );
  end;

  // TNwDataClass 应该有一个全局的实例, 用于提供数据. 在下面的代码中, 就以
  // instanceDataClass 为这个实例
implementation

 { TNwDataClass  }
constructor TNwDataClass.Create;
begin
 inherited Create;
  Link:=TEventAgent.Create(Self);
end;
destructor TNwDataClass.Destroy;
begin
  Link.Free;
  inherited;
end;
 procedure TNwDataClass.AddData( Name, City, CellPhone:String; Age: Integer );
 begin
   //数据处理代码,忽视Link的存在
  if Assigned(FOnData) then FOnData(Name, City, CellPhone, Age);
 end;

  { TNwInterface }
  procedure TNwInterface.FormCreate( Sender: TObject );
  var  V:TOnData;
  begin
    V:= Self.OnEvent;
    instanceDataClass.Link.AddEventNotifier('OnData', TMethod(V));
   V:= Self.OnEvent2;
    instanceDataClass.Link.AddEventNotifier('OnData', TMethod(V));
   end;

  procedure TNwInterface.FormDestroy( Sender: TObject );
  var  V:TOnData;
  begin
    V:= Self.OnEvent;
    instanceDataClass.Link.RemoveEventNotifier('OnData', TMethod(V));
    V:= Self.OnEvent2;
    instanceDataClass.Link.RemoveEventNotifier('OnData', TMethod(V));
  end;  

  procedure TNwInterface.OnEvent( Name, City, CellPhone:String; Age: Integer );
  begin
    AddDataToList( Name, City, CellPhone, Age);
  end;

  procedure TNwInterface.OnEvent2( Name, City, CellPhone:String; Age: Integer );
  begin
    AddDataToFile( Name, City, CellPhone, Age);
  end;

  procedure TNwInterface.AddDataToList( Name, City, CellPhone:String; Age: Integer );
  begin
    //用于处理显示数据的代码.
  end;

  procedure TNwInterface.AddDataToFile( Name, City, CellPhone:String; Age: Integer );
  begin
    //用于保存数据的代码.
  end;