Приведение 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; 

Я был очень рад видеть, что код действительно компилируется. Я этого не ожидал. К сожалению, я получаю различные исключения, когда код выполняется. Например, я получаю AV at address 0000000000419A32 reading address FFFFFFFFFFFFFFFF в System._IntfCopy при вызове GetMultiCasterFunction.

Есть ли что-то не так, как я использую анонимную функцию? FYI, я делаю это с 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 и ассемблерного типа.Если вы хотите использовать анонимный метод, вам нужно использовать другой 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, им пришлось обновить свой код thunking для поддержки 64-битного.