通过匿名函数将 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, 00, );
  asm
    MOV BYTE PTR [EAX], $B9
    MOV ECX, Data
    MOV DWORD PTR [EAX+], ECX
    MOV BYTE PTR [EAX+], A
    MOV BYTE PTR [EAX+], 
    MOV BYTE PTR [EAX+], 
    MOV BYTE PTR [EAX+], $B9
    MOV ECX, Code
    MOV DWORD PTR [EAX+], ECX
    MOV BYTE PTR [EAX+$D], $FF
    MOV BYTE PTR [EAX+$E], $E1
  end;
{$ENDIF}
end;

procedure FreeProcInstance(ProcInstance: Pointer);
begin
  VirtualFree(ProcInstance, 15, 00);
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

Is there anything wrong on how I use anonymous function?

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

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 window 过程绝对不是接口。

因此，如果您希望继续这种方式，您将需要坚持使用 VirtualAlloc 和汇编程序类型的转换方法。如果您想使用匿名方法，则需要使用能够调用接口方法的不同 asm。

要了解如何将调用方法的 asm 调整为调用匿名方法的代码，我建议您阅读以下内容：

如果您准备使用 of object 方法，那么 Delphi VCL 代码将向您展示如何操作。此技术在 TWinControl 的 window 过程处理中得到了例证。当然，当 Embarcadero 推出 64 位 Windows 编译器和 64 位 VCL 时，他们必须更新他们的 thunking 代码以支持 64 位。

通过匿名函数将 TCallbackThunk 带到 64 位

Bringing TCallbackThunk to 64-bit via anonymous function

delphi

winapi

assembly

32bit-64bit

anonymous-function