delphi – 如何使AllocateHwnd线程安全？

VCL组件设计为仅从应用程序的主线程使用.对于视觉部件,这不会给我带来任何困难.然而,我有时希望能够使用例如TTMI的非可视化组件从后台线程.或者确实只是创建一个隐藏的窗口.这是不安全的,因为依赖于AllocateHwnd.现在,AllocateHwnd不是线程安全的,我所理解的是设计.

有没有一个容易的解决方案,让我从后台线程使用AllocateHwnd？

解决方法

这个问题可以像这样解决：

>获取或实现一个线程安全版本的AllocateHwnd和DeallocateHwnd.
>替换VCL不安全版本的这些功能.

对于项目1,我使用Primož Gabrijelcic’s代码,如他在blog article上所述的主题.对于项目2,我简单地使用非常有名的技巧在运行时修补代码,并用无条件的JMP指令来替代不安全例程的开始,将指令重定向到线程安全功能.

将它们放在一起产生以下单元.

(* Makes AllocateHwnd safe to call from threads. For example this makes TTimer
   safe to use from threads.  Include this unit as early as possible in your
   .dpr file.  It must come after any memory manager,but it must be included
   immediately after that before any included unit has an opportunity to call
   Classes.AllocateHwnd. *)
unit MakeAllocateHwndThreadsafe;

interface

implementation

{$IF CompilerVersion >= 23}{$DEFINE ScopedUnitNames}{$IFEND}
uses
  {$IFDEF ScopedUnitNames}System.SysUtils{$ELSE}SysUtils{$ENDIF},{$IFDEF ScopedUnitNames}System.Classes{$ELSE}Classes{$ENDIF},{$IFDEF ScopedUnitNames}Winapi.Windows{$ELSE}Windows{$ENDIF},{$IFDEF ScopedUnitNames}Winapi.Messages{$ELSE}Messages{$ENDIF};

const //DSiAllocateHwnd window extra data offsets
  GWL_METHODCODE = SizeOf(pointer) * 0;
  GWL_METHODDATA = SizeOf(pointer) * 1;

  //DSiAllocateHwnd hidden window (and window class) name
  CDSiHiddenWindowName = 'DSiUtilWindow';

var
  //DSiAllocateHwnd lock
  GDSiWndHandlerCritSect: TRTLCriticalSection;
  //Count of registered windows in this instance
  GDSiWndHandlerCount: integer;

//Class message dispatcher for the DSiUtilWindow class. Fetches instance's WndProc from
//the window extra data and calls it.
function DSiClassWndProc(Window: HWND; Message,WParam,LParam: longint): longint; stdcall;
var
  instanceWndProc: TMethod;
  msg            : TMessage;
begin
  {$IFDEF cpuX64}
  instanceWndProc.Code := pointer(getwindowlongPtr(Window,GWL_METHODCODE));
  instanceWndProc.Data := pointer(getwindowlongPtr(Window,GWL_METHODDATA));
  {$ELSE}
  instanceWndProc.Code := pointer(getwindowlong(Window,GWL_METHODCODE));
  instanceWndProc.Data := pointer(getwindowlong(Window,GWL_METHODDATA));
  {$ENDIF ~cpuX64}
  if Assigned(TWndMethod(instanceWndProc)) then
  begin
    msg.msg := Message;
    msg.wParam := WParam;
    msg.lParam := LParam;
    msg.Result := 0;
    TWndMethod(instanceWndProc)(msg);
    Result := msg.Result
  end
  else
    Result := DefWindowProc(Window,Message,LParam);
end; { DSiClassWndProc }

//Thread-safe AllocateHwnd.
//  @author  gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
//                 TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
//  @since   2007-05-30
function DSiAllocateHWnd(wndProcmethod: TWndMethod): HWND;
var
  alreadyRegistered: boolean;
  tempClass        : TWndClass;
  utilWindowClass  : TWndClass;
begin
  Result := 0;
  FillChar(utilWindowClass,SizeOf(utilWindowClass),0);
  EnterCriticalSection(GDSiWndHandlerCritSect);
  try
    alreadyRegistered := GetClassInfo(HInstance,CDSiHiddenWindowName,tempClass);
    if (not alreadyRegistered) or (tempClass.lpfnWndProc <> @DSiClassWndProc) then begin
      if alreadyRegistered then
        {$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName,HInstance);
      utilWindowClass.lpszClassName := CDSiHiddenWindowName;
      utilWindowClass.hInstance := HInstance;
      utilWindowClass.lpfnWndProc := @DSiClassWndProc;
      utilWindowClass.cbWndExtra := SizeOf(TMethod);
      if {$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.RegisterClass(utilWindowClass) = 0 then
        raise Exception.CreateFmt('Unable to register DSiWin32 hidden window class. %s',[SysErrorMessage(GetLastError)]);
    end;
    Result := CreateWindowEx(WS_EX_TOOLWINDOW,'',WS_POPUP,HInstance,nil);
    if Result = 0 then
      raise Exception.CreateFmt('Unable to create DSiWin32 hidden window. %s',[SysErrorMessage(GetLastError)]);
    {$IFDEF cpuX64}
    SetwindowLongPtr(Result,GWL_METHODDATA,NativeInt(TMethod(wndProcmethod).Data));
    SetwindowLongPtr(Result,GWL_METHODCODE,NativeInt(TMethod(wndProcmethod).Code));
    {$ELSE}
    SetwindowLong(Result,cardinal(TMethod(wndProcmethod).Data));
    SetwindowLong(Result,cardinal(TMethod(wndProcmethod).Code));
    {$ENDIF ~cpuX64}
    Inc(GDSiWndHandlerCount);
  finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiAllocateHWnd }

//Thread-safe DeallocateHwnd.
//  @author  gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
//                 TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
//  @since   2007-05-30
procedure DSiDeallocateHWnd(wnd: HWND);
begin
  if wnd = 0 then
    Exit;
  DestroyWindow(wnd);
  EnterCriticalSection(GDSiWndHandlerCritSect);
  try
    Dec(GDSiWndHandlerCount);
    if GDSiWndHandlerCount <= 0 then
      {$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName,HInstance);
  finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiDeallocateHWnd }

procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
  OldProtect: DWORD;
begin
  if VirtualProtect(Address,Size,PAGE_EXECUTE_READWRITE,OldProtect) then begin
    Move(NewCode,Address^,Size);
    FlushInstructionCache(GetCurrentProcess,Address,Size);
    VirtualProtect(Address,OldProtect,@OldProtect);
  end;
end;

type
  PInstruction = ^TInstruction;
  TInstruction = packed record
    Opcode: Byte;
    Offset: Integer;
  end;

procedure RedirectProcedure(OldAddress,NewAddress: Pointer);
var
  NewCode: TInstruction;
begin
  NewCode.Opcode := $E9;//jump relative
  NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
  PatchCode(OldAddress,NewCode,SizeOf(NewCode));
end;

initialization
  InitializeCriticalSection(GDSiWndHandlerCritSect);
  RedirectProcedure(@AllocateHWnd,@DSiAllocateHWnd);
  RedirectProcedure(@DeallocateHWnd,@DSiDeallocateHWnd);

finalization
  DeleteCriticalSection(GDSiWndHandlerCritSect);

end.

在.dpr文件的单位列表中必须包含该单元.显然,它不会出现在任何自定义内存管理器之前,但它应该立即出现.原因是在对AllocateHwnd进行任何调用之前必须先安装替换例程.

更新我已经合并了最新版本的Primož的代码,他寄给我.