一个灵巧的Delphi多播实事件现方案.

转自我的旧博客

一个灵巧的Delphi多播实现方案.必须是支持泛型的Delphi版本.也就是Delphi2009以后.强烈建议用DelphiXE.

用法就是例如写一个Class指定一个Event,触发的时候会通知多个Method.和.NET的多播事件机制是一样的.

用法例如:

type
TFakeButton = class(TButton)
private
FMultiCast_OnClik : TMulticastEvent<TNotifyEvent>;

public
constructor Create(AOwnder : TComponent);override;
destructor Destroy; override;

procedure Click; override;

property MultiCast_OnClik : TMulticastEvent<TNotifyEvent> read FMultiCast_OnClik;
end;

{ TTest }

procedure TFakeButton.Click;
begin
inherited;
//这样调用可以通知多个事件
FMultiCast_OnClik.Invok(Self);
end;

constructor TFakeButton.Create(AOwnder : TComponent);
begin
inherited Create(AOwnder);
FMultiCast_OnClik := TMulticastEvent<TNotifyEvent>.Create;
end;

destructor TFakeButton.Destroy;
begin
FMultiCast_OnClik.Free;
inherited Destroy;
end;

//

procedure TForm2.Button1Click(Sender: TObject);
var
Test : TFakeButton;
begin
Test := TFakeButton.Create(Self);
Test.MultiCast_OnClik.Add(TestA);
Test.MultiCast_OnClik.Add(TestB);
Test.SetBounds(0,0,100,100);
test.Caption := ‘试试多播';
Test.Parent := Self;
end;

procedure TForm2.TestA(Sender: TObject);
begin
ShowMessage(Caption);
end;

procedure TForm2.TestB(Sender: TObject);
begin
ShowMessage(FormatDateTime(‘yyyy-mm-dd hh:nn:ss’,now));
end;

在按钮上点一下,直接会触发TestA,和TestB.

这个做法主要是省了写一个事件容器,然后循环调用的麻烦.

下面是方案的代码:

{
一个多播方法的实现.
和一位同事(一位Delphi牛人)一起讨论了一下Delphi下多播事件的实现.
他提供了一个易博龙技术牛人的多播事件方案.这个方案非常牛,但是依赖Delphi的
编译器特性太多,只能用在开启优化的代码.而DelphiXE默认Debug是关闭优化的.

重写了一个TMulticastEvent.这个不依赖Delphi的编译器产生的代码特性.
其中InternalInvoke基本上是那位易博龙大牛的代码.加了详细的注释

wr960204. 2011.5.28
}
unit MultiCastEventUtils;

interface
uses
Generics.collections, TypInfo, ObjAuto, SysUtils;

type
//
TMulticastEvent = class
private
FMethods : TList<TMethod>;
FInternalDispatcher: TMethod;
//悲催的是泛型类的方法不能内嵌汇编,只能通过一个非泛型的父类来实现
procedure InternalInvoke(Params: PParameters; StackSize: Integer);
public
constructor Create;
destructor Destroy; override;
end;

TMulticastEvent<T > = class(TMulticastEvent)
private

FEntry : T;
function ConvertToMethod(var Value):TMethod;
procedure SetEntry(var AEntry);
public
constructor Create;
destructor Destroy; override;
procedure Add(AMethod : T);
procedure Remove(AMethod : T);
function IndexOf(AMethod: T): Integer;

property Invok : T read FEntry;
end;

implementation

{ TMulticastEvent<T> }

procedure TMulticastEvent<T>.Add(AMethod: T);
var
m : TMethod;
begin
m := ConvertToMethod(AMethod);
if FMethods.IndexOf(m) < 0 then
FMethods.Add(m);
end;

function TMulticastEvent<T>.ConvertToMethod(var Value): TMethod;
begin
Result := TMethod(Value);
end;

constructor TMulticastEvent<T>.Create();
var
MethInfo: PTypeInfo;
TypeData: PTypeData;
begin
MethInfo := TypeInfo(T);
if MethInfo^.Kind <> tkMethod then
begin
raise Exception.Create(‘T only is Method(Member function)!’);

end;
TypeData := GetTypeData(MethInfo);
Inherited;
FInternalDispatcher := CreateMethodPointer(InternalInvoke, TypeData);
SetEntry(FEntry);
end;

destructor TMulticastEvent<T>.Destroy;
begin
ReleaseMethodPointer(FInternalDispatcher);

inherited Destroy;
end;

function TMulticastEvent<T>.IndexOf(AMethod: T): Integer;
begin
Result := FMethods.IndexOf(ConvertToMethod(AMethod));
end;

procedure TMulticastEvent<T>.Remove(AMethod: T);
begin
FMethods.Remove(ConvertToMethod(AMethod));
end;

procedure TMulticastEvent<T>.SetEntry(var AEntry);
begin
TMethod(AEntry) := FInternalDispatcher;
end;

{ TMulticastEvent }

constructor TMulticastEvent.Create;
begin
FMethods := TList<TMethod>.Create;
end;

destructor TMulticastEvent.Destroy;
begin
FMethods.Free;
inherited Destroy;
end;

procedure TMulticastEvent.InternalInvoke(Params: PParameters; StackSize: Integer);
var
LMethod: TMethod;
begin
for LMethod in FMethods do
begin
//如果用到了栈(也就是Register约定参数大于2或者stdcall,cdecl约定)就把栈内所有数据都拷贝参数栈里面
if StackSize > 0 then
asm
MOV ECX,StackSize???? //Move的第三个参数,同时为下一步Sub ESP做准备
SUB ESP,ECX?????????? //把栈顶 – StackSize(栈是负向的)
MOV EDX,ESP?????????? //Move的第二个参数
MOV EAX,Params
LEA EAX,[EAX].TParameters.Stack[8] //Move的第一个参数
CALL System.Move
end;
//Register协议填写三个寄存器,EAX肯定是Self,如果是其他协议寄存器被填写也没啥影响
asm
MOV EAX,Params???????? //把Params读到EAX
MOV EDX,[EAX].TParameters.Registers.DWORD[0] //EDX
MOV ECX,[EAX].TParameters.Registers.DWORD[4] //EAX

MOV EAX,LMethod.Data//把Method.Data给到EAX,如果是Register约定就是Self.否则也没影响
CALL LMethod.Code//调用Method.Data
end;
end;
end;

end.

此条目发表在Delphi, 未分类分类目录。将固定链接加入收藏夹。

一个灵巧的Delphi多播实事件现方案.》有 8 条评论

  1. 子航说:

    武大侠,有个问题请教,如果我想做一个事件多播代理,比如:

    //每个事件的传递的参数不一样。参数传递方式也可能不一致
    TEvent1=procedure(Sender:TObject; Param1:Integer) of Object;
    TEvent2=procedure(Sender:TObject; Param1:Integer; Param2:String) of Object;cdcel;
    TEvent3=procedure(Sender:TObject; Param1:Integer; Param2:String) of Object;stdcall;

    TEventn=….

    //TEventObject是一个示例,表示任意带方法的Property的对象。
    TEventObject=class
    protected
    FEvent1:TEvent1;
    FEvent2:TEvent2;

    FEventn:TEventn;
    public
    property Event1:TEvent1 read FEvent1 write FEvent1
    property Event2:TEvent2 read FEvent2 write FEvent2;
    ……….
    property Eventn:TEventn read FEventn write FEventn;
    end;

    多播事件代理:代理指定对象中所有是Method的Property。

    TEventInfo=class //单个事件信息
    FNotifierList=TList; //多播列表
    FMethod:TMethod;//原事件地址
    FMethodRtti:TRttiMethod;
    FMethodType:TRttiInvokableType;
    ….
    procedure AgentProc(…); //单个事件的原地址,比如TEventObject.Event1:=AgentProg;
    procedure Invoke(…);
    end;

    procedure TEventInfo.AgentProc(…)
    begin
    。。。。 //寄存器、堆栈保存
    Invoke(…);
    end;
    procedure TEventInfo.Invoke(…)
    var
    i:integer;
    begin
    for i:=0 to FNotifierList.Count-1 do
    begin
    Statck prepare; //参数寄存器,堆栈还原
    call FNotifierList[i].Code;
    end;
    end;

    TEventAgent=class
    private
    FObject:TObject; //被代理对象,
    FEvents:TDictionary; //被代理对象中,所有事件信息以及多播接收方法列表。
    protected
    procedure Prepare;
    public
    constructor Create(aObject:TObject);
    end;

    constructor TEventAgent.Create(aObject:TObject);
    begin
    inherited Create;
    FObject:=aObject;
    Prepare;
    end;

    procedure TEventAgent.Prepare;
    var
    PropList:PPropList;
    M:TMethod;
    N, i:Integer;
    EventObject: TEventInfo;
    Context:TRttiContext;
    begin
    N:=GetPropList(FObject.ClassInfo, [tkMethod, FPropList, True);
    for i:=0 to N-1 do
    begin
    if FPropList[i].GetProc=nil then Continue;
    M:=GetMethodProp(FObject, FPropList[i]);
    EventInfo:= TEventInfo.Create;
    EventInfo.FEventName:=FPropList[i].Name;
    EventInfo.FMethod:=M;
    EventInfo.FMethodType:=Context.GetType(FPropList[[i].PropType^) as TRttiInvokableType;
    SetMethodProp(FObject, FPropList[i], EventObject.AgentProc); //将FObject的事件关联到E
    FEvents.Add(M, EventInfo); //生成FObject的事件列表
    end;
    end;

    上面的程序是我的一个构思,通过TEventAgent自动代理TObject的所有事件。在TEventAgent内部,为TObject的每个事件生成一个TEventInfo,并将此事件关联到TEventInfo.AgentProc,
    然后由TEventInfo.AgentProc调用TEventInfo.Invoke,来完成多播事件的调用。
    本人水平有限,不知该如何实现TEventInfo.AgentProc和 TEventInfo.Invoke方法,看你此文章后,觉得您有解决的方法,特请大师指点。

  2. 子航说:

    TEventAgent是一个TObject的事件多播代理器,将一个TObject传给TEventAgent后,
    TEventAgent.Prepare通过RTTI,扫描TObject所有事件,并为每个事件提供多播功能。

  3. 子航说:

    武大侠,我已经实现了一个简单的事件多播代理器:
    http://www.cnblogs.com/hezihang/p/3299481.html

  4. 罗汉说:

    武大侠,想请教一下datasnap的相关知识,借用这里的评论请教一下:
    1.服务器的池应该如何设计,什么情况下需要池,比如SM(TServerMethods)池,SQLConnection池,SQLDataSet池等;池必须与当前session(TDSSessionManager.GetThreadSession)挂钩,还是无所谓?我现在的设计是不挂钩的,在SC(ServerContainer)里面随便从池里取一个SM。
    2.客户端如何实现多线程访问服务器的方法(包括数据库相关访问)。是否需要SMClient对象池和SQLConnection连接池?是否每执行一次服务器方法,都需要从池里获取一个SMClient以及SQLConnection才行?我试了几种方案,都不行,总是发生莫名奇妙的问题。
    望不吝赐教,深表感谢。

    • admin说:

      啊…别问我数据库的知识,快十年没用过数据库了,尽管当年Midas,ClientDataSet什么的非常熟练,但现在都忘得差不多了

      • 罗汉说:

        大侠,其实也不完全是数据库的内容。
        我只是对线程这块迷糊了。
        而且想知道datasnap究竟怎么回事,各个组件之间究竟什么关系,哪些是需要自己处理线程的,哪些是组件自身就支持线程(不需要再池化)的。
        如果能在这些方面提点一下小弟,那就太好了。

发表评论

电子邮件地址不会被公开。

您可以使用这些HTML标签和属性: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <strike> <strong>

你必须启用JavaScript