利用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 测试成功.

 

复制代码
  1 unit utObjEventAgent;
  2 
  3 interface
  4 
  5 uses System.Generics.Collections, DSharp.Core.Events, System.TypInfo, Classes;
  6 
  7 type
  8   TEventLinker=class(DSharp.Core.Events.TEvent)     //单个事件的多播器
  9   protected
 10     FLinkedObject: TObject;
 11     FLinkedProperty: PPropInfo;
 12     FOriginal:TMethod;
 13 
 14     FEventTypeData:PTypeData;
 15     FEventName:String;
 16     procedure MethodAdded(const Method: TMethod); override;
 17     procedure MethodRemoved(const Method: TMethod); override;
 18     procedure Notify(Sender: TObject; const Item: TMethod;
 19       Action: System.Generics.Collections.TCollectionNotification); override;
 20     property Owner;
 21     property RefCount;
 22   public
 23     constructor Create(LinkedObj:TObject; LinkedPrpt:PPropInfo);
 24     destructor Destroy; override;
 25   end;
 26 
 27   TEventAgent=class                 //对象的事件多播代理
 28     protected
 29       FOwner:TObject;
 30       FPropList: PPropList;
 31       FNameList:TDictionary<String, TEventLinker>;
 32       procedure Prepare; virtual;
 33       procedure Clear;
 34     public
 35       constructor Create(aOwner:TObject); virtual;
 36       destructor Destroy;override;
 37       function GetEventCount: Int32;
 38       function GetEventName(Index: Int32): PWideChar;
 39       procedure AddEventNotifier(EventName: String; const NotifierMethod: TMethod);overload;    // 添加事件处理函数
 40       procedure RemoveEventNotifier(EventName: String; const NotifierMethod: TMethod);overload; // 移除时间处理函数
 41   end;
 42 
 43 implementation
 44 
 45 uses System.Rtti;
 46 
 47 { TEventLinker }
 48 
 49 constructor TEventLinker.Create(LinkedObj:TObject; LinkedPrpt:PPropInfo);
 50 begin
 51   inherited Create(LinkedPrpt.PropType^, nil);
 52   FLinkedObject:=LinkedObj;
 53   FLinkedProperty:=LinkedPrpt;
 54   FEventName:=FLinkedProperty^.Name;
 55   FOriginal:=GetMethodProp(FLinkedObject, FLinkedProperty);
 56   SetMethodProp(FLinkedObject, FLinkedProperty, Self.GetInvoke);
 57   if Assigned(FOriginal.Data) and Assigned(FOriginal.Code) then Add(FOriginal);  //将原事件方法加入多播列表
 58 end;
 59 
 60 destructor TEventLinker.Destroy;
 61 begin
 62   SetMethodProp(FLinkedObject, FLinkedProperty, FOriginal);
 63   inherited;
 64 end;
 65 
 66 procedure TEventLinker.MethodAdded(const Method: TMethod);
 67 begin
 68 end;
 69 
 70 procedure TEventLinker.MethodRemoved(const Method: TMethod);
 71 begin
 72 end;
 73 
 74 procedure TEventLinker.Notify(Sender: TObject; const Item: TMethod;
 75   Action: System.Generics.Collections.TCollectionNotification);
 76 begin
 77 end;
 78 
 79 { TEventAgent }
 80 
 81 procedure TEventAgent.AddEventNotifier(EventName: String;
 82   const NotifierMethod: TMethod);
 83 var
 84   V:TEventLinker;
 85 begin
 86   if FNameList.TryGetValue(EventName, V) then
 87   begin
 88     if V.IndexOf(NotifierMethod)<0 then
 89       V.Add(NotifierMethod);
 90   end;
 91 end;
 92 
 93 procedure TEventAgent.Clear;
 94   var
 95     Item: TPair<String, TEventLinker>;
 96   begin
 97     for Item in FNameList do
 98       Item.Value.Free;
 99     FNameList.Clear;
100     if Assigned(FPropList) then FreeMem(FPropList);
101   end;
102 
103 constructor TEventAgent.Create(aOwner:TObject);
104 begin
105   inherited Create;
106   FNameList:=TDictionary<String, TEventLinker>.Create;
107   FOwner:=aOwner;
108   Prepare;
109 end;
110 
111 destructor TEventAgent.Destroy;
112 begin
113   Clear;
114   FNameList.Free;
115   inherited;
116 end;
117 
118 function TEventAgent.GetEventCount: Int32;
119 begin
120   Result:=FNameList.Count;
121 end;
122 
123 function TEventAgent.GetEventName(Index: Int32): PWideChar;
124 begin
125   Result:=PWideChar(FNameList.Keys.ToArray[Index]);
126 end;
127 
128 procedure TEventAgent.Prepare;
129 var
130   N, i:Integer;
131   Linker:TEventLinker;
132   Context: TRttiContext;
133 begin
134   Clear;
135   N:=GetPropList(FOwner.ClassInfo, FPropList);
136   for i := 0 to N-1 do
137     if FPropList^[i].PropType^.Kind = tkMethod then
138   begin
139     if FPropList[i].GetProc=nil then Continue;
140     Linker:=TEventLinker.Create(FOwner, FPropList[i]);
141     Linker.FEventName:=FPropList[i].Name;
142     FNameList.Add(Linker.FEventName, Linker);
143   end;
144 end;
145 
146 
147 procedure TEventAgent.RemoveEventNotifier(EventName: String;
148   const NotifierMethod: TMethod);
149 var
150   V:TEventLinker;
151 begin
152   if FNameList.TryGetValue(EventName, V) then
153   begin
154     V.Remove(NotifierMethod);
155   end;
156 end;
157 
158 end.
复制代码

 

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

复制代码
 1 unit Unit1;
 2 
 3 interface
 4 
 5 uses
 6   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
 7   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, utObjEventAgent, DSharp.Core.Events, ObjAuto,
 8   Vcl.StdCtrls;
 9 
10 type
11   TForm1 = class(TForm)
12     Button1: TButton;
13     Memo1: TMemo;
14     procedure FormCreate(Sender: TObject);
15     procedure Button1Click(Sender: TObject);
16     procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
17       Shift: TShiftState; X, Y: Integer);
18   private
19     { Private declarations }
20     procedure OnClick1(Sender:TObject);
21     procedure OnClick2(Sender:TObject);
22     procedure Button1MouseDown1(Sender: TObject; Button: TMouseButton;
23       Shift: TShiftState; X, Y: Integer);
24     procedure Button1MouseDown2(Sender: TObject; Button: TMouseButton;
25       Shift: TShiftState; X, Y: Integer);
26   public
27     { Public declarations }
28     FAgent:TEventAgent;
29   end;
30 
31 var
32   Form1: TForm1;
33 
34 implementation
35 
36 uses System.Rtti;
37 
38 {$R *.dfm}
39 
40 procedure TForm1.Button1Click(Sender: TObject);
41 begin
42   Memo1.Lines.Add('Button1Click');
43 end;
44 
45 procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
46   Shift: TShiftState; X, Y: Integer);
47 begin
48   Memo1.Lines.Add(Format('Clicked at (%d, %d)', [X, Y]));
49 end;
50 
51 procedure TForm1.Button1MouseDown1(Sender: TObject; Button: TMouseButton;
52   Shift: TShiftState; X, Y: Integer);
53 begin
54   Memo1.Lines.Add('Button1MouseDown1')
55 end;
56 
57 procedure TForm1.Button1MouseDown2(Sender: TObject; Button: TMouseButton;
58   Shift: TShiftState; X, Y: Integer);
59 begin
60   Memo1.Lines.Add('Button1MouseDown2')
61 end;
62 
63 procedure TForm1.FormCreate(Sender: TObject);
64 var
65   V:TNotifyEvent;
66   M:TMouseEvent;
67 begin
68   FAgent:=TEventAgent.Create(Button1);
69   V:= Self.OnClick1;
70   FAgent.AddEventNotifier('OnClick', TMethod(V));
71   V:= Self.OnClick2;
72   FAgent.AddEventNotifier('OnClick', TMethod(V));
73   M:= Self.Button1MouseDown1;
74   FAgent.AddEventNotifier('OnMouseDown', TMethod(M));
75   M:= Self.Button1MouseDown2;
76   FAgent.AddEventNotifier('OnMouseDown', TMethod(M));
77 end;
78 
79 procedure TForm1.OnClick1(Sender: TObject);
80 begin
81   Memo1.Lines.Add('OnClick1');
82 end;
83 
84 procedure TForm1.OnClick2(Sender: TObject);
85 begin
86   Memo1.Lines.Add('OnClick2');
87 end;
88 
89 end.
复制代码

 测试程序dfm文件

复制代码
 1 object Form1: TForm1
 2   Left = 0
 3   Top = 0
 4   Caption = 'Form1'
 5   ClientHeight = 311
 6   ClientWidth = 643
 7   OnCreate = FormCreate
 8   object Button1: TButton
 9     Left = 88
10     Top = 56
11     Width = 75
12     Height = 25
13     Caption = 'Button1'
14     OnClick = Button1Click
15     OnMouseDown = Button1MouseDown
16   end
17   object Memo1: TMemo
18     Left = 264
19     Top = 32
20     Width = 329
21     Height = 225
22     Lines.Strings = (
23       'Memo1')
24   end
25 end
复制代码

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

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

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

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


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

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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.接着，只需在不同的模块去接收你的数据，例如数据存储模块：

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
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.数据解码模块

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
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 实现事件侦听与触发”的例子：

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
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;

　　

posted @   子航  阅读(2267)  评论(6)  编辑  收藏  举报
编辑推荐：
· 开发者必知的日志记录最佳实践
· SQL Server 2025 AI相关能力初探
· Linux系列：如何用 C#调用 C方法造成内存泄露
· AI与.NET技术实操系列（二）：开始使用ML.NET
· 记一次.NET内存居高不下排查解决与启示
阅读排行：
· Manus重磅发布：全球首款通用AI代理技术深度解析与实战指南
· 被坑几百块钱后，我竟然真的恢复了删除的微信聊天记录！
· 没有Manus邀请码？试试免邀请码的MGX或者开源的OpenManus吧
· 园子的第一款AI主题卫衣上架——"HELLO! HOW CAN I ASSIST YOU TODAY
· 【自荐】一款简洁、开源的在线白板工具 Drawnix
点击右上角即可分享
微信分享提示