LCL: added AllocateHWnd and implemented it for win32 (bug #8563) from Felipe

git-svn-id: trunk@10856 -

lcl/include/intfbaselcl.inc

@@ -44,6 +44,11 @@ begin
   Result := nil;
 end;
 
+function TWidgetSet.AllocateHWnd(Method: TLCLWndMethod): HWND;
+begin
+  Result := 0;
+end;
+
 procedure TWidgetSet.AttachMenuToWindow(AMenuObject: TComponent);
 begin
 end;
@@ -134,6 +139,11 @@ begin
   DeleteObject(Clip);
 end;
 
+procedure TWidgetSet.DeallocateHWnd(Wnd: HWND);
+begin
+
+end;
+
 procedure TWidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
 begin
 end;

lcl/include/lclintf.inc

@@ -51,6 +51,11 @@ begin
   Result:=WidgetSet.AddProcessEventHandler(AHandle, AEventHandler, AData);
 end;
 
+function AllocateHWnd(Method: TLCLWndMethod): HWND;
+begin
+  Result := WidgetSet.AllocateHWnd(Method);
+end;
+
 procedure AttachMenuToWindow(AMenuObject: TComponent);
 begin
   WidgetSet.AttachMenuToWindow(AMenuObject);
@@ -130,6 +135,11 @@ begin
   Result := WidgetSet.DCClipRegionValid(DC);
 end;
 
+procedure DeallocateHWnd(Wnd: HWND);
+begin
+  WidgetSet.DeallocateHWnd(Wnd);
+end;
+
 procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent);
 begin
   WidgetSet.DrawArrow(Arrow, Canvas);

lcl/include/lclintfh.inc

@@ -40,6 +40,7 @@
 function AddEventHandler(AHandle: THandle; AFlags: dword; AEventHandler: TWaitHandleEvent; AData: PtrInt): PEventHandler; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
 function AddProcessEventHandler(AHandle: THandle; AEventHandler: TChildExitEvent; AData: PtrInt): PProcessEventHandler; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
 function AddPipeEventHandler(AHandle: THandle; AEventHandler: TPipeEvent; AData: PtrInt): PPipeEventHandler; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
+function AllocateHWnd(Method: TLCLWndMethod): HWND; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
 procedure AttachMenuToWindow(AMenuObject: TComponent); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
 
 procedure CallDefaultWndHandler(Sender: TObject; var Message); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@@ -61,6 +62,7 @@ function CreateRegionCopy(SrcRGN: hRGN): hRGN; {$IFDEF IF_BASE_MEMBER}virtual;{$
 function CreateStandardCursor(ACursor: SmallInt): hCursor; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
 
 function DCClipRegionValid(DC: HDC): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
+procedure DeallocateHWnd(Wnd: HWND); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
 procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
 
 function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;  {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}

lcl/interfacebase.pp

@@ -52,6 +52,8 @@ type
   TPipeEvent = procedure(AData: PtrInt; AReasons: TPipeReasons) of object;
   TSocketEvent = procedure(AData: PtrInt; AFlags: dword) of object;
 
+  TLCLWndMethod = procedure(var TheMessage: TLMessage) of Object;
+
   { TWidgetSet }
 
   TWidgetSet = class(TObject)

lcl/interfaces/win32/win32lclintf.inc

@@ -170,6 +170,90 @@ begin
   end;
 end;
 
+{------------------------------------------------------------------------------
+  Method: CallbackAllocateHWnd
+  Params:   None
+  Returns:  Nothing
+
+  Callback for the AllocateHWnd function
+ ------------------------------------------------------------------------------}
+procedure CallbackAllocateHWnd(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam); stdcall;
+var
+  Msg: TLMessage;
+  PMethod: ^TLCLWndMethod;
+begin
+  FillChar(Msg, SizeOf(Msg), #0);
+  
+  Msg.msg := uMsg;
+  Msg.wParam := wParam;
+  Msg.lParam := lParam;
+
+  {------------------------------------------------------------------------------
+    Here we get the callback WndMethod associated with this window
+   ------------------------------------------------------------------------------}
+  PMethod := Pointer(Widgetset.GetWindowLong(ahwnd, GWL_USERDATA));
+
+  if Assigned(PMethod) then PMethod^(Msg);
+   
+  Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
+end;
+
+{------------------------------------------------------------------------------
+  Method: TWin32WidgetSet.AllocateHWnd
+  Params:   Method  - The callback method for the window. Can be nil
+  Returns:  A window handle
+
+  Allocates a non-visible window that can be utilized to receive and send message
+  
+  On Windows, you must call Windows.DefWindowProc(MyHandle, Msg.msg, Msg.wParam, msg.lParam);
+  in your callback function, if you provide one at all, of course.
+ ------------------------------------------------------------------------------}
+function TWin32WidgetSet.AllocateHWnd(Method: TLCLWndMethod): HWND;
+var
+  PMethod: ^TLCLWndMethod;
+begin
+  Result := Windows.CreateWindow(@ClsName[0],
+   '', WS_OVERLAPPED, 0, 0, 0, 0, 0, 0, MainInstance, nil);
+
+  {------------------------------------------------------------------------------
+    SetWindowLong has only space for 1 pointer on each slot, but a method is
+   referenced as a structure with 2 pointers, so here we allocate memory for
+   the structure before it can be used to transport data between the callback
+   and this function
+   ------------------------------------------------------------------------------}
+  if Assigned(Method) then
+  begin
+    Getmem(PMethod, SizeOf(TMethod));
+    PMethod^ := Method;
+
+    Self.SetWindowLong(Result, GWL_USERDATA, PtrInt(PMethod));
+  end;
+  
+  Self.SetWindowLong(Result, GWL_WNDPROC, PtrInt(@CallbackAllocateHWnd))
+end;
+
+{------------------------------------------------------------------------------
+  Method: TWin32WidgetSet.DeallocateHWnd
+  Params:   Wnd   - A Window handle, that was created with AllocateHWnd
+  Returns:  Nothing
+ ------------------------------------------------------------------------------}
+procedure TWin32WidgetSet.DeallocateHWnd(Wnd: HWND);
+var
+  PMethod: ^TLCLWndMethod;
+begin
+  PMethod := Pointer(Self.GetWindowLong(Wnd, GWL_USERDATA));
+
+  if Wnd <> 0 then Windows.DestroyWindow(Wnd);
+
+  {------------------------------------------------------------------------------
+    This must be done after DestroyWindow, otherwise a Access Violation will
+   happen when WM_CLOSE message is sent to the callback
+
+    This memory is for the TMethod structure allocated on AllocateHWnd
+   ------------------------------------------------------------------------------}
+  if Assigned(PMethod) then Freemem(PMethod);
+end;
+
 {------------------------------------------------------------------------------
   Procedure:
   Params:

lcl/interfaces/win32/win32lclintfh.inc

@@ -35,9 +35,11 @@ function AddPipeEventHandler(AHandle: THandle;
   AEventHandler: TPipeEvent; AData: PtrInt): PPipeEventHandler; override;
 function AddProcessEventHandler(AHandle: THandle;
   AEventHandler: TChildExitEvent; AData: PtrInt): PProcessEventHandler; override;
+function AllocateHWnd(Method: TLCLWndMethod): HWND; override;
 
 function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
 
+procedure DeallocateHWnd(Wnd: HWND); override;
 procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
 
 function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override;