ObjectPascal Magic Programming
Closure of "stdcall"

WindowsXP SP2以降では使えません。

Windowsのコールバック関数に、インスタンスメソッド(procedure of object)を渡せず、歯痒い思いをしている人は多いのではないでしょうか。
ここで紹介する方法を用いると、stdcall呼びだし規約でコールバックを受けとる際、Selfポインタを付加できます。
例えば、ウィンドウに対応するクラスを作る際、インスタンスへのポインタは、SetWindowLongやSetPropを使ってウィンドウ関数へ渡すのが普通と思われますが、この方法を用いると、直にSelf付きでやって来るというアクロバットができます。

この例はウィンドウ関数ですが、stdcallなら何でもOKです。

program Instance;

{$WARN SYMBOL_PLATFORM OFF}

uses
  Windows, CommDlg, Messages;

type
  TProxy = packed record
    popECX: Byte;
    movEDX: Byte;
    Instance: Pointer;
    pushEDX: Byte;
    pushECX: Byte;
    movEAX: Byte;
    Code: Pointer;
    jmpEAX: Word;
  end;

function CreateProxy(Method: TMethod): TProxy;
begin
  Result.popECX := $59;
  Result.movEDX := $ba;
  Result.Instance := Method.Data;
  Result.pushEDX := $52;
  Result.pushECX := $51;
  Result.movEAX := $b8;
  Result.Code := Method.Code;
  Result.jmpEAX := $e0ff;
end;

type
  TWindow = class(TObject)
  private
    FProxy: TProxy;
    FHandle: HWND;
    FEdit: HWND;
    FMenu: HMENU;
  protected
    function WindowProc(Window: HWND; Message: UINT; W: WPARAM; L: LPARAM): LRESULT;
      stdcall;
    procedure OnResize;
    procedure OnCreate;
    procedure OnDestroy;
    procedure OnActivate;
    procedure OnCommand(ID: WORD);
  public
    constructor Create;
    property Handle: HWND read FHandle;
  end;

const
  idLoad = 11;
  idSaveAs = 12;
  idExit = 13;
  idAbout = 21;

constructor TWindow.Create;
var
  P: function (Window: HWND; Message: UINT; W: WPARAM; L: LPARAM): LRESULT of object;
    stdcall;
begin
  inherited;
  P := WindowProc;
  FProxy := CreateProxy(TMethod(P));
end;

procedure TWindow.OnActivate;
begin
  SetFocus(FEdit);
end;

procedure TWindow.OnCommand(ID: WORD);
var
  FileName: array[0..1023] of WideChar;
  FileDialog: OPENFILENAMEW;
  function InitFileDialog: OPENFILENAMEW;
  begin
    FillChar(FileName, SizeOf(WideChar) * 2, 0);
    FillChar(Result, SizeOf(Result), 0);
    Result.lStructSize := SizeOf(Result);
    Result.hWndOwner := Handle;
    Result.hInstance := hInstance;
    Result.lpstrFilter := 'テキスト(*.txt)'#0'*.txt'#0'全て(*.*)'#0'*.*'#0#0;
    Result.nFilterIndex := 1;
    Result.lpstrFile := FileName;
    Result.nMaxFile := 1023;
    Result.Flags := OFN_EXPLORER or OFN_HIDEREADONLY;
    Result.lpstrDefExt := 'txt';
  end;
  procedure Load;
  var
    T: WideString;
    U: UTF8String;
    F: THandle;
    R: DWORD;
  begin
    F := CreateFileW(FileName, GENERIC_READ, FILE_SHARE_READ, nil,
      OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    SetLength(U, GetFileSize(F, nil));
    ReadFile(F, Pointer(U)^, Length(U), R, nil);
    CloseHandle(F);
    T := UTF8Decode(U);
    SetWindowTextW(FEdit, PWideChar(T));
  end;
  procedure Save;
  var
    T: WideString;
    U: UTF8String;
    F: THandle;
    R: DWORD;
  begin
    SetLength(T, GetWindowTextLengthW(FEdit));
    GetWindowTextW(FEdit, PWideChar(T), Length(T) + 1);
    U := UTF8Encode(T);
    F := CreateFileW(FileName, GENERIC_READ or GENERIC_WRITE, 0, nil,
      CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
    WriteFile(F, Pointer(U)^, Length(U), R, nil);
    CloseHandle(F);
  end;
begin
  case ID of
  idLoad:
  begin
    FileDialog := InitFileDialog;
    FileDialog.Flags := FileDialog.Flags or OFN_PATHMUSTEXIST or OFN_FILEMUSTEXIST;
    if GetOpenFileNameW(FileDialog) then Load;
  end;
  idSaveAs:
  begin
    FileDialog := InitFileDialog;
    FileDialog.Flags := FileDialog.Flags or OFN_OVERWRITEPROMPT;
    if GetSaveFileNameW(FileDialog) then Save;
  end;
  idExit:
    PostMessage(Handle, WM_SYSCOMMAND, SC_CLOSE, 0);
  idAbout:
    MessageBoxW(Handle, 'SamplePad', 'About', MB_ICONINFORMATION);
  end;
end;

procedure TWindow.OnCreate;
var
  SubMenu: HMENU;
begin
  FMenu := CreateMenu;
  SubMenu := CreatePopupMenu;
  AppendMenuW(FMenu, MF_POPUP, SubMenu, '&File');
  AppendMenuW(SubMenu, MF_STRING, idLoad, '&Load...');
  AppendMenuW(SubMenu, MF_STRING, idSaveAs, 'Save &As...');
  AppendMenuW(SubMenu, MF_SEPARATOR, idExit, '');
  AppendMenuW(SubMenu, MF_STRING, idExit, 'E&xit');
  SubMenu := CreatePopupMenu;
  AppendMenuW(FMenu, MF_POPUP, SubMenu, '&Help');
  AppendMenuW(SubMenu, MF_STRING, idAbout, '&About...');
  SetMenu(Handle, FMenu);
  FEdit := CreateWindowExW(WS_EX_CLIENTEDGE, 'EDIT', '',
    WS_VISIBLE or WS_CHILD or WS_VSCROLL or WS_HSCROLL or
    ES_MULTILINE or ES_AUTOVSCROLL or ES_AUTOHSCROLL or ES_WANTRETURN,
    0, 0, 100, 100, Handle, 0, hInstance, nil)
end;

procedure TWindow.OnDestroy;
begin
  SetMenu(Handle, 0);
  DestroyMenu(FMenu);
end;

procedure TWindow.OnResize;
var
  R: TRect;
begin
  if FEdit <> 0 then
  begin
    GetClientRect(Handle, R);
    MoveWindow(FEdit, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, True);
  end
end;

function TWindow.
  WindowProc(Window: HWND; Message: UINT; W: WPARAM; L: LPARAM): LRESULT;
  stdcall;
begin
  case Message of
  WM_NCCREATE:
    FHandle := Window;
  WM_CREATE:
    OnCreate;
  WM_ACTIVATE:
    OnActivate;
  WM_SIZE:
    OnResize;
  WM_COMMAND:
    OnCommand(W);
  WM_DESTROY:
  begin
    OnDestroy;
    PostQuitMessage(0);
  end;
  end;
  Result := DefWindowProcW(Window, Message, W, L);
end;

const
  ClassName = 'Sample';
var
  Window: TWindow;
  Message: TMsg;
  WindowClass: TWndClassW = (
    style: 0; cbClsExtra: 0; cbWndExtra: 0;
    lpszMenuName: nil; lpszClassName: ClassName);
begin
  Window := TWindow.Create;

  WindowClass.lpfnWndProc := @Window.FProxy;
  WindowClass.hInstance := HInstance;
  WindowClass.hIcon := LoadIcon(0, IDI_APPLICATION);
  WindowClass.hCursor := LoadCursor(0, IDC_ARROW);
  WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
  RegisterClassW(WindowClass);

  CreateWindowW(ClassName, 'SamplePad', WS_OVERLAPPEDWINDOW,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    0, 0, hInstance, nil);

  ShowWindow(Window.Handle, CmdShow);
  UpdateWindow(Window.Handle);
  while GetMessageW(Message, 0, 0, 0) do
  begin
    TranslateMessage(Message);
    DispatchMessageW(Message);
  end;
  ExitCode := Message.wParam;

  Window.Free;
end.

というわけで種明かし。 stdcallは、引数を右から左にスタックへ積みます。つまり、Selfは最後です。また、引数の解放は関数側なので、勝手に引数を増やしても、その結果が呼ばれる側の関数の引数サイズと一致していれば、暴走せずに実行を続けることができます。

cdeclの場合、引数は同じく右からですが、引数の解放が呼びだし側なので、勝手に引数を追加できません。
pascal規約の場合、引数は左からなので、Selfは最初に積まねばならず、後から追加するのは至難の業です。
register(fastcall)の場合、レジスタを使って引数が渡されるため、Self付加コード中でレジスタを使うことができません。
これらの規約でも、引数を特定してなら可能でしょうが、どんな関数にも使える、最後にSelfをpushするだけのコードが書けるのは、stdcallのみです。 WindowsAPIがstdcall規約だったことは、非常に幸運と言えるでしょう。

動作としては、VCLのMakeObjectInstanceそのものなのですが、あっちは丁寧にVirtualAllocにPAGE_EXECUTE_READWRITEを付けて実行可能メモリを確保しています。実はそんなことをしなくても、現行のWindowsですと、読み取り可能メモリは実行できてしまうので、Self付加コードをインスタンス中に埋めこんで省メモリ＆解放の手間要らずという手抜きが~~できてしまったりします、という話。このコードが将来のWindowsで動き続けるかどうかの保証は一切いたしません^^~~ できなくなりました。 WindowsXP SP2で保護が追加されましたので動かなくなります。VirtualAllocかVirtualProtectで実行許可を与える必要があります。すると必然的に開放か再び属性Offかどちらかをしないといけなくなりますので、旨味は減りました。いや、属性Onのまま突っ切っても殊更問題も無いわけですが…。

「引数を追加できるstdcall」が本題といえば直接関係ない話なのですが、上に挙げたサンプルが動かなくなってしまうので、注意してくださいませ。

ちなみに、先読みバリバリな現行CPUで書き込み可能メモリを実行させると、効率は悪化するようです。

ObjectPascal Magic Programming Closure of "stdcall"

ObjectPascal Magic Programming
Closure of "stdcall"