通过匿名函数将 TCallbackThunk 带到 64 位
Bringing TCallbackThunk to 64-bit via anonymous function
我在将一些代码移植到 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 位做一个单独的解决方案。但那应该是最后的手段。
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 调整为调用匿名方法的代码,我建议您阅读以下内容:
- 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
的 window 过程处理中得到了例证。当然,当 Embarcadero 推出 64 位 Windows 编译器和 64 位 VCL 时,他们必须更新他们的 thunking 代码以支持 64 位。
我在将一些代码移植到 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 位做一个单独的解决方案。但那应该是最后的手段。
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 调整为调用匿名方法的代码,我建议您阅读以下内容:
- 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
的 window 过程处理中得到了例证。当然,当 Embarcadero 推出 64 位 Windows 编译器和 64 位 VCL 时,他们必须更新他们的 thunking 代码以支持 64 位。