具有 stdcall 调用约定的回调系统的组件模式

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 干扰的方式。

Answer 2

由于您无法修改 DLL 代码，因此您别无选择，只能使用问题中代码样式的 thunk。您没有其他方法可以将实例信息传递给回调函数。