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

Question

这个问题从这个arised 一个.
问题是:创建非可视组件,可以从系统中保存许多回调命令.用户可以在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; 

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