zoukankan      html  css  js  c++  java
  • 一个灵巧的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.
  • 相关阅读:
    挂载硬盘,提示 mount: unknown filesystem type 'LVM2_member'的解决方案
    mongo3.4 配置文件 注意事项
    Rsync 传输不需要输入密码
    Robomongo 0.9.0 连接mongo数据库时,提示连接失败 的解决方案
    linux 安装 mongo
    mysql GTID主从复制(主库在线,添加新丛库)
    计算机网络原理精讲第四章--网络层
    Chrome浏览器商店安装的插件保存到本地
    计算机网络原理精讲第三章--链路层
    计算机网络原理精讲第二章--物理层
  • 原文地址:https://www.cnblogs.com/key-ok/p/3506483.html
Copyright © 2011-2022 走看看