Implementation of Delphi multicast event agent based on RTTI

Recommended for you: Get network issues from WhatsUp Gold. Not end users.

  We know that each Delphi object can contain multiple Property, Property can be methods, such as the TButton.OnClick attribute. Delphi only provide

One to one set, not directly asked TButton.OnClick to invoke multiple methods, and Java with Listener mode is similar to the AddListener method for providing multicast.

Blog Delphi multicast stems from the idea of Allen Bauer: ,

Wu were heroes to this idea of cnWizard is implemented on Win32 Delphi multicast mechanism, and see: applied to the cnWizard;

The open source project DSharp multicast mechanism is more complete, can provide the interface based multicast, see: https://code.google.com/p/delphisorcery/

I hope the basis on the previous research, the realization of a target event multicast agent, TEventAgent is a TObject event multicast agent, a TObject to a TEventAgent, TEventAgent scan all TObject events, and to provide multicast function for each event.

The following procedure is a simple example, cited the DSharp.Core.Events.pas unit, and successfully in the Delphi XE3 test.


  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)     //Multicast is a single event
  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                 //Object event multicast agent
 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;    // Add the event handler
 40       procedure RemoveEventNotifier(EventName: String; const NotifierMethod: TMethod);overload; // To remove the time processing function
 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);  //The original event method for adding multicast list
 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.

The test program demonstrated a TButton event multicast agent, OnClick, OnMouseDown were 3 multicast method.

The test program:

 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.

 Test procedures DFM file

 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


Recommended from our users: Dynamic Network Monitoring from WhatsUp Gold from IPSwitch. Free Download

Posted by Howar at November 24, 2013 - 3:53 PM