delphi - 具有标准调用约定的回调系统的组件模式

Question

这个问题源于这个 one .
问题是:创建可以容纳来自系统的许多回调命令的非可视化组件。用户可以在 IDE 中定义无限数量的回调。回调将在 TCollection 中定义为 TCollectionItem。

这种模式工作得很好，但也有一些缺点。 (后述)因此我想知道是否可以做得更好 ;-)

这是一个主要组件，用户可以通过CommandsTable集合在IDE中定义无限数量的回调函数

TMainComp = class(TComponent)  
private
   CallbacksArray: array [0..x] of pointer;
   procedure BuildCallbacksArray;    
public 
   procedure Start;
published
   property CommandsTable: TCommandCollection read FCommandsTable write SetCommandsTable;
end;

每个集合项看起来是这样的，InternalCommandFunction 是回调，从系统调用。 (Stdcall 调用约定)

TCommandCollectionItem = class(TCollectionItem)
public
   function InternalCommandFunction(ASomeNotUsefullPointer:pointer; ASomeInteger: integer): Word; stdcall;
published
   property OnEventCommand: TComandFunc read FOnEventCommand write FOnEventCommand;
end; 

TComandFunc = function(AParam1: integer; AParam2: integer): Word of Object;

这是一个实现。整个过程可以从“开始”程序开始

procedure TMainComp.Start;
begin  
  // fill CallBackPointers array with pointers to CallbackFunction
  BuildCallbacksArray;

  // function AddThread is from EXTERNAL dll. This function creates a new thread, 
  // and parameter is a pointer to an array of pointers (callback functions).
  // New created thread in system should call our defined callbacks (commands) 
  AddThread(@CallbacksArray);
end;   

这是有问题的代码。我认为唯一的方法是如何获得指向“InternalEventFunction”函数的指针就是使用 MethodToProcedure() 函数。

procedure TMainComp.BuildCallbacksArray;
begin
   for i := 0 to FCommandsTable.Count - 1 do begin
      // it will not compile
      //CallbacksArray[i] := @FCommandsTable.Items[i].InternalEventFunctionWork;

      // compiles, but not work
      //CallbacksArray[i] := @TCommandCollectionItem.InternalCommandFunction;

      // works pretty good
      CallbacksArray[i] := MethodToProcedure(FCommandsTable.Items[i], @TCommandCollectionItem.InternalCommandFunction);

   end;         
end;

function TEventCollectionItem.InternalEventFunction(ASomeNotUsefullPointer:pointer; ASomeInteger: integer): Word; stdcall;
begin
  // some important preprocessing stuff
  // ...


  if Assigned(FOnEventCommand) then begin
     FOnEventCommand(Param1, Param2);
  end;
end;

正如我之前所述，它工作正常，但函数 MethodToProcedure() 使用 Thunk 技术。我想避免这种情况，因为程序将无法在启用数据执行保护 (DEP) 的系统上运行并且在 64 位架构上，可能需要全新的 MethodToProcedure() 函数。
你知道一些更好的模式吗？

---

只是为了完成，这是一个 MethodToProcedure()。 (不知道原作者是谁)

TMethodToProc = packed record
    popEax: Byte;
    pushSelf: record
      opcode: Byte;
      Self: Pointer;
    end;
    pushEax: Byte;
    jump: record
      opcode: Byte;
      modRm: Byte;
      pTarget: ^Pointer;
      target: Pointer;
    end;
  end;    

function MethodToProcedure(self: TObject; methodAddr: Pointer): Pointer;
var
  mtp: ^TMethodToProc absolute Result;
begin
  New(mtp);
  with mtp^ do
  begin
    popEax := $58;
    pushSelf.opcode := $68;
    pushSelf.Self := Self;
    pushEax := $50;
    jump.opcode := $FF;
    jump.modRm := $25;
    jump.pTarget := @jump.target;
    jump.target := methodAddr;
  end;
end;    

Answer 1

如果您可以更改 DLL 以接受记录数组而不是指针数组，那么您可以将记录定义为同时包含回调指针和对象指针，并为回调签名提供一个额外的指针参数。然后定义一个简单的代理函数，DLL可以调用这个对象指针作为参数，代理可以通过那个指针调用真正的对象方法。无需 thunking 或低级汇编，无需特殊编码即可在 32 位和 64 位中运行。类似于以下内容:

type
  TCallback = function(AUserData: Pointer; AParam1, AParam2: Integer): Word; stdcall;

  TCallbackRec = packed record
    Callback: TCallback;
    UserData: Pointer; 
  end;

  TCommandFunc = function(AParam1, AParam2: integer): Word of object; 

  TCommandCollectionItem = class(TCollectionItem) 
  private
    FOnEventCommand: TCommandFunc;
    function InternalCommandFunction(APara1, AParam2: Integer): Word; 
  published 
    property OnEventCommand: TCommandFunc read FOnEventCommand write FOnEventCommand; 
  end;  

  TMainComp = class(TComponent)  
  private
    CallbacksArray: array of TCallbackRec;
  public 
    procedure Start;
  published
    property CommandsTable: TCommandCollection read FCommandsTable write SetCommandsTable;
  end;

.

function CallbackProxy(AUSerData: Pointer; AParam1, AParam2: Integer): Word; stdcall;
begin
  Result := TEventCollectionItem(AUserData).InternalEventFunction(AParam1, AParam2);
end;

procedure TMainComp.Start; 
var
  i: Integer;
begin 
  SetLength(CallbacksArray, FCommandsTable.Count);
  for i := 0 to FCommandsTable.Count - 1 do begin 
    CallbacksArray[i].Callback := @CallbackProxy; 
    CallbacksArray[i].UserData := FCommandsTable.Items[i]; 
  end;          
  AddThread(@CallbacksArray[0]);
end;    

function TEventCollectionItem.InternalEventFunction(AParam1, AParam2: Integer): Word;
begin 
  // ... 
  if Assigned(FOnEventCommand) then begin 
    Result := FOnEventCommand(Param1, Param2); 
  end; 
end; 

如果这不是一个选项，那么使用 thunk 是给定您所展示的设计的唯一解决方案，并且您需要单独的 32 位和 64 位 thunk。不过不用担心 DEP。只需使用 VirtualAlloc() 和 VirtualProtect() 而不是 New()，这样您就可以将分配的内存标记为包含可执行代码。这就是 VCL 自己的 thunk(例如，TWinControl 和 TTimer 使用的)如何避免 DEP 干扰。