通过匿名函数将TCallbackThunk转换为64位

Question

我有一个将代码移植到64位的问题。它的目的是为WinAPI声明一个方法函数作为回调函数。有些人可能知道这是TCallbackThunk（见this SO answer for some further explanation）。

我认为这段代码比较老，但是使用了相同的方法。它也应该与TCallbackThunk一起工作。 让我告诉你的代码，因为它适用于32位：

unit SubClassing; 

interface 

uses 
    Windows; 

type 
    TCallbackMode = (cbNoCallSuper, cbKeepResult, cbUseSuperResult); 

    TWndProc = procedure(Window: HWND; var Message: LongInt; 
    var WParam: Longint; var LParam: Longint; 
    var LResult: LongInt; var Mode: TCallbackMode) of object; 

type 
    PSubClassInfo = ^TSubClassInfo; 
    TSubClassInfo = record 
    OriginalWndProc: Pointer; 
    NewWndProc: TWndProc; 
    Handle: HWnd; 
    Stub: Pointer; 
    end; 

function SubClassWindow(Handle: HWnd; WndProc: TWndProc): PSubClassInfo; 
procedure UnSubClassWindow(var Info: PSubClassInfo); 

implementation 

uses 
    SysUtils; 

function MakeProcInstance(Data: Pointer; Code: Pointer): Pointer; 
begin 
{$IFDEF WIN64} 
    Assert(False); // lacks implementation for 64-bit 
{$ELSE} 
    // A simple GetMem will _not_ do the trick. 
    // To avoid conflicting with DEP it is essential that the page will 
    // be marked as being executable. 
    Result := VirtualAlloc(nil, 15, $3000, $40); 
    asm 
    MOV BYTE PTR [EAX], $B9 
    MOV ECX, Data 
    MOV DWORD PTR [EAX+$1], ECX 
    MOV BYTE PTR [EAX+$5], $5A 
    MOV BYTE PTR [EAX+$6], $51 
    MOV BYTE PTR [EAX+$7], $52 
    MOV BYTE PTR [EAX+$8], $B9 
    MOV ECX, Code 
    MOV DWORD PTR [EAX+$9], ECX 
    MOV BYTE PTR [EAX+$D], $FF 
    MOV BYTE PTR [EAX+$E], $E1 
    end; 
{$ENDIF} 
end; 

procedure FreeProcInstance(ProcInstance: Pointer); 
begin 
    VirtualFree(ProcInstance, 15, $8000); 
end; 

function MultiCaster(SubClassInfo: PSubClassInfo; Window: HWND; Message, 
    WParam: Longint; LParam: Longint): LongInt; stdcall; 
var 
    Mode: TCallbackMode; 
    Res: LongInt; 
begin 
    SubClassInfo.NewWndProc(Window, Message, WParam, LParam, Result, Mode); 

    if Mode <> cbNoCallSuper then 
    begin 
    Res := CallWindowProc(SubClassInfo^.OriginalWndProc, Window, Message, wParam, lParam); 
    if Mode = cbUseSuperResult then 
     Result := Res; 
    end; 
end; 

function SubClassWindow(Handle: HWnd; WndProc: TWndProc): PSubClassInfo; 
begin 
    Result := new(PSubClassInfo); 

    ZeroMemory(Result, SizeOf(TSubClassInfo)); 
    Result^.NewWndProc := WndProc; 
    Result^.Handle := Handle; 
    Result^.Stub := MakeProcInstance(Result, @MultiCaster); 
    Result^.OriginalWndProc := Pointer(SetWindowLong(Handle, GWL_WNDPROC, Integer(Result^.Stub))); 
end; 

procedure UnSubClassWindow(var Info: PSubClassInfo); 
begin 
    if Assigned(Info) then 
    begin 
    if Assigned(Info^.OriginalWndProc) then 
    begin 
     SetWindowLong(Info^.Handle, GWL_WNDPROC, Integer(Info^.OriginalWndProc)); 
     FreeProcInstance(Info^.Stub); 
    end; 

    Dispose(Info); 
    end; 
    Info := nil; 
end; 

end. 

之前移植的MakeProcInstance汇编代码为64位，我想先尝试与匿名功能的解决方案。这会在汇编代码变得过时时提供更好的可维护性。因此，我宣布

TMultiCasterFunc = reference to function(Window: HWND; Message, 
    WParam: Longint; LParam: Longint): LongInt stdcall; 

，并重新声明TSubClassInfo作为

TSubClassInfo = record 
    OriginalWndProc: Pointer; 
    NewWndProc: TWndProc; 
    Handle: HWnd; 
    Stub: TMultiCasterFunc; 
end; 

然后，我实现了一个功能

function GetMultiCasterFunction(const ASubClassInfo: PSubClassInfo): TMultiCasterFunc; 
begin 
    Result := function(Window: HWND; Message, WParam: Longint; LParam: Longint): LongInt stdcall 
      begin 
       Result := MultiCaster(ASubClassInfo, Window, Message, WParam, LParam); 
      end; 
end; 

功能SubClassWindow和UnSubClassWindow进行编辑，以这样的：

function SubClassWindow(Handle: HWnd; WndProc: TWndProc): PSubClassInfo; 
begin 
    Result := new(PSubClassInfo); 

    ZeroMemory(Result, SizeOf(TSubClassInfo)); 
    Result^.NewWndProc := WndProc; 
    Result^.Handle := Handle; 
    Result^.Stub := GetMultiCasterFunction(Result); 
    Result^.OriginalWndProc := Pointer(SetWindowLong(Handle, GWL_WNDPROC, NativeInt(@(Result^.Stub)))); 
end; 

procedure UnSubClassWindow(var Info: PSubClassInfo); 
begin 
    if Assigned(Info) then 
    begin 
    if Assigned(Info^.OriginalWndProc) then 
    begin 
     SetWindowLong(Info^.Handle, GWL_WNDPROC, Integer(Info^.OriginalWndProc)); 
     FreeProcInstance(@(Info^.Stub)); 
    end; 

    Dispose(Info); 
    end; 
    Info := nil; 
end; 

我很高兴看到代码真的编译。我并不期待这一点。 不幸的是，当代码被执行时，我得到了各种异常。例如，拨打GetMultiCasterFunction时，我在System._IntfCopy中收到AV at address 0000000000419A32 reading address FFFFFFFFFFFFFFFF。

我如何使用匿名函数有什么不对吗？仅供参考，我正在用Delphi XE4做这件事。我应该尝试什么？

我在ASM有一些经验。所以我可以为64位做一个单独的解决方案。但那应该是最后的手段。

Answer 1

我如何使用匿名函数有什么不对吗？

是的。当您使用SetWindowLong传递GWL_WNDPROC时，您需要提供一个窗口过程。这是以下类型的函数指针：

LRESULT CALLBACK WindowProc(
    _In_ HWND hwnd, 
    _In_ UINT uMsg, 
    _In_ WPARAM wParam, 
    _In_ LPARAM lParam 
); 

我把这个从documentation。

在Delphi的语法，这将是：

function WindowProc(
    hwnd: HWND; 
    uMsg: UINT; 
    wParam: WPARAM; 
    lParam: LPARAM 
): LRESULT; stdcall; 

一开始，请注意使用的类型。与你非常不同。在64位版本中，WPARAM，LPARAM和LRESULT都是64位类型。你应该解决这个问题。

但是，最大的问题是这与匿名方法不兼容。 Delphi中的一个匿名方法被实现为一个接口。 Win32窗口过程绝对不是接口。

所以，如果你想继续在这个方面，你将需要坚持VirtualAlloc和汇编类型thunking方法。如果你想使用匿名方法，那么你需要使用不同的asm来调用接口方法。

要学会如何去适应你的汇编调用的方法转换成代码调用一个匿名方法，我建议你阅读以下内容：

• http://blog.barrkel.com/2010/01/using-anonymous-methods-in-method.html
• http://delphisorcery.blogspot.co.uk/2015/06/anonymous-method-overloading.html
• https://sergworks.wordpress.com/2010/01/27/anonimous-methods-in-delphi-the-internals/

如果您准备使用of object方法，那么Delphi VCL代码将告诉您如何去做。该技术在TWinControl的窗口过程处理中被举例说明。自然，当Embarcadero推出64位Windows编译器和64位VCL时，他们必须更新其thunk代码才能支持64位。