Various improvements to fpgui

git-svn-id: trunk@15025 -

.gitattributes

@@ -3072,8 +3072,11 @@ lcl/interfaces/cocoa/Makefile.fpc svneol=native#text/plain
 lcl/interfaces/fpgui/Makefile.fpc svneol=native#text/plain
 lcl/interfaces/fpgui/README.txt svneol=native#text/plain
 lcl/interfaces/fpgui/fpguiint.pp svneol=native#text/pascal
+lcl/interfaces/fpgui/fpguilclintf.inc svneol=native#text/plain
+lcl/interfaces/fpgui/fpguilclintfh.inc svneol=native#text/plain
 lcl/interfaces/fpgui/fpguiobject.inc svneol=native#text/pascal
 lcl/interfaces/fpgui/fpguiobjects.pas svneol=native#text/plain
+lcl/interfaces/fpgui/fpguiproc.pas svneol=native#text/plain
 lcl/interfaces/fpgui/fpguiwinapi.inc svneol=native#text/plain
 lcl/interfaces/fpgui/fpguiwinapih.inc svneol=native#text/plain
 lcl/interfaces/fpgui/fpguiwsactnlist.pp svneol=native#text/pascal

lcl/interfaces/fpgui/fpguiint.pp

@@ -84,7 +84,7 @@ type
     function IsValidGDIObject(const GDIObject: HGDIOBJ): Boolean; virtual;
   public
     {$I fpguiwinapih.inc}
-    {.$I fpguilclintfh.inc}
+    {$I fpguilclintfh.inc}
   end;
 
 
@@ -129,7 +129,7 @@ uses
 
 {$I fpguiobject.inc}
 {$I fpguiwinapi.inc}
-{.$I fpguilclintf.inc}
+{$I fpguilclintf.inc}
 {.$I fpguicallback.inc}
 
 

lcl/interfaces/fpgui/fpguilclintf.inc

@@ -0,0 +1,45 @@
+{%MainUnit fpguiint.pp}
+
+{******************************************************************************
+                 All FPGUI interface communication implementations.
+                   Initial Revision  : Sun Nov 23 23:53:53 2003
+
+
+  !! Keep alphabetical !!
+
+  Support routines go to gtkproc.pp
+
+ ******************************************************************************
+ Implementation
+ ******************************************************************************
+
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.modifiedLGPL, included in this distribution,        *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+//##apiwiz##sps##   // Do not remove
+
+{------------------------------------------------------------------------------
+  function FontCanUTF8(Font: HFont): boolean;
+
+  True if font recognizes Unicode UTF8 encoding.
+  
+  FPGUI supports only Unicode
+ ------------------------------------------------------------------------------}
+function TFpGuiWidgetSet.FontCanUTF8(Font: HFont): boolean;
+begin
+  Result := True;
+end;
+
+//##apiwiz##eps##   // Do not remove, no wizard declaration after this line
+

lcl/interfaces/fpgui/fpguilclintfh.inc

@@ -0,0 +1,68 @@
+{%MainUnit fpguiint.pp}
+
+{******************************************************************************
+                 All FPGUI interface communication implementations.
+                   Initial Revision  : Sun Nov 23 23:53:53 2003
+
+
+  !! Keep alphabetical !!
+
+ ******************************************************************************
+ Interface
+ ******************************************************************************
+
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.modifiedLGPL, included in this distribution,        *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+//##apiwiz##sps##   // Do not remove
+
+{function AddEventHandler(AHandle: THandle; AFlags: dword;
+  AEventHandler: TWaitHandleEvent; AData: PtrInt): PEventHandler; override;
+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;
+procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); override;
+
+function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect;
+  Str: PChar; Count: Longint; Dx: PInteger): Boolean; override;}
+
+function FontCanUTF8(Font: HFont): boolean; override;
+
+{function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override;
+function GetControlConstraints(Constraints: TObject): boolean; override;
+
+function IntfSendsUTF8KeyPress: boolean; override;
+
+function LoadStockPixmap(StockID: longint; var Mask: HBitmap) : HBitmap; override;
+
+function RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean = False): Boolean; override;
+function RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): Boolean; override;
+function RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): Boolean; override;
+function RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; const ARect: TRect): Boolean; override;
+function RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC; const ARect: TRect): Boolean; override;
+
+procedure RemoveEventHandler(var AHandler: PEventHandler); override;
+procedure RemovePipeEventHandler(var AHandler: PPipeEventHandler); override;
+procedure RemoveProcessEventHandler(var AHandler: PProcessEventHandler); override;}
+
+
+//##apiwiz##eps##   // Do not remove, no wizard declaration after this line
+

lcl/interfaces/fpgui/fpguiproc.pas

@@ -0,0 +1,56 @@
+{
+ *****************************************************************************
+ *                                FpGuiProc.pp                               *
+ *                              ---------------                              *
+ *                                                                           *
+ *                                                                           *
+ *****************************************************************************
+
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+unit fpguiproc;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, gfxbase, Graphics;
+
+function TColorToTfpgColor(AColor: TColor): TfpgColor;
+
+implementation
+
+{
+  Converts from TColor to TfpgColor
+
+  TfpgColor   = type longword;    // Always in RRGGBB (Alpha, Red, Green, Blue) format!!
+}
+function TColorToTfpgColor(AColor: TColor): TfpgColor;
+var
+  RGBColor: TColor;
+  RGBTriple: TRGBTriple;
+begin
+  RGBColor := ColorToRGB(AColor);
+
+  RGBTriple.Alpha := 0;
+  RGBTriple.Red := Graphics.Red(RGBColor);
+  RGBTriple.Green := Graphics.Green(RGBColor);
+  RGBTriple.Blue := Graphics.Blue(RGBColor);
+
+  Result := RGBTripleTofpgColor(RGBTriple);
+end;
+
+end.
+

lcl/interfaces/fpgui/fpguiwinapi.inc

@@ -70,6 +70,74 @@ begin
   DC.Free;
 end;
 
+function TFpGuiWidgetSet.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint;
+  Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
+var
+  ADC: TFpGuiDeviceContext absolute DC;
+  AStr: string;
+begin
+  AStr := string(Str);
+
+  ADC.fpgCanvas.DrawText(X, Y, AStr, [txtLeft]);
+end;
+
+function TFpGuiWidgetSet.GetSysColor(nIndex: Integer): DWORD;
+begin
+  if (nIndex < 0) or (nIndex > MAX_SYS_COLORS) then
+  begin
+    {$ifdef VerboseFPGUIWinAPI}
+      WriteLn('Trace:Unknown lcl system color: [TFpGuiWidgetSet.GetSysColor]');
+    {$endif}
+    exit;
+  end;
+
+  case nIndex of
+{    COLOR_SCROLLBAR               : Result:=clGray;
+    COLOR_BACKGROUND              : Result:=;
+    COLOR_ACTIVECAPTION           : Result:=;
+    COLOR_INACTIVECAPTION         : Result:=;
+    COLOR_MENU                    : Result:=;}
+    COLOR_WINDOW                  : Result:=clWhite;
+{    COLOR_WINDOWFRAME             : Result:=;
+    COLOR_MENUTEXT                : Result:=;
+    COLOR_WINDOWTEXT              : Result:=;
+    COLOR_CAPTIONTEXT             : Result:=GetColor(QPaletteActive,   QPaletteText);
+    COLOR_ACTIVEBORDER            : Result:=GetColor(QPaletteActive,   QPaletteWindow);
+    COLOR_INACTIVEBORDER          : Result:=GetColor(QPaletteInactive, QPaletteWindow);
+    COLOR_APPWORKSPACE            : Result:=GetColor(QPaletteActive,   QPaletteWindow);
+    COLOR_HIGHLIGHT               : Result:=GetColor(QPaletteActive,   QPaletteHighlight);
+    COLOR_HIGHLIGHTTEXT           : Result:=GetColor(QPaletteActive,   QPaletteHighlightedText);}
+    COLOR_BTNFACE                 : Result:=clLtGray;
+{    COLOR_BTNSHADOW               : Result:=GetColor(QPaletteActive,   QPaletteDark);
+    COLOR_GRAYTEXT                : Result:=GetColor(QPaletteActive,   QPaletteText);
+    COLOR_BTNTEXT                 : Result:=GetColor(QPaletteActive,   QPaletteButtonText);
+    COLOR_INACTIVECAPTIONTEXT     : Result:=GetColor(QPaletteInactive, QPaletteText);
+    COLOR_BTNHIGHLIGHT            : Result:=GetColor(QPaletteActive,   QPaletteLight);
+    COLOR_3DDKSHADOW              : Result:=GetColor(QPaletteActive,   QPaletteShadow);
+    COLOR_3DLIGHT                 : Result:=GetColor(QPaletteActive,   QPaletteMidlight);
+    COLOR_INFOTEXT                : Result:=GetClInfo(False);
+    COLOR_INFOBK                  : Result:=GetClInfo(True);
+    // PBD: 25 is unassigned in all the docs I can find
+    //      if someone finds what this is supposed to be then fill it in
+    //      note defaults below, and cl[ColorConst] in graphics
+    COLOR_HOTLIGHT                : Result:=GetColor(QPaletteActive,   QPaletteLight);
+    COLOR_GRADIENTACTIVECAPTION   : Result:=GetColor(QPaletteActive,   QPaletteHighlight);
+    COLOR_GRADIENTINACTIVECAPTION : Result:=GetColor(QPaletteInactive, QPaletteBase);
+    COLOR_FORM                    : Result:=GetColor(QPaletteActive,   QPaletteWindow);
+
+    COLOR_clForeground..COLOR_clHighlightedText
+                                  : Result:=GetColor(QPaletteActive,   nIndex - COLOR_clForeground);
+    COLOR_clNormalForeground..COLOR_clNormalHighlightedText
+                                  : Result:=GetColor(QPaletteInactive, nIndex - COLOR_clNormalForeground);
+    COLOR_clDisabledForeground..COLOR_clDisabledHighlightedText
+                                  : Result:=GetColor(QPaletteDisabled, nIndex - COLOR_clDisabledForeground);
+    COLOR_clActiveForeground..COLOR_clActiveHighlightedText
+                                  : Result:=GetColor(QPaletteActive,   nIndex - COLOR_clActiveForeground);}
+  else
+    Result:=0;
+  end;
+end;
+
 function TFpGuiWidgetSet.Rectangle(DC: HDC; X1, Y1, X2, Y2: Integer): Boolean;
 var
   ADC: TFpGuiDeviceContext absolute DC;

lcl/interfaces/fpgui/fpguiwinapih.inc

@@ -80,10 +80,10 @@ function EndPaint(Handle: hwnd; var PS: TPaintStruct): Integer; override;
 {procedure EnterCriticalSection(var CritSection: TCriticalSection); override;
 function EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; Callback: FontEnumExProc; Lparam: LParam; Flags: dword): longint; override;
 function ExcludeClipRect(dc: hdc; Left, Top, Right, Bottom : Integer) : Integer; override;
-function ExtSelectClipRGN(dc: hdc; rgn : hrgn; Mode : Longint) : Integer;  override;
+function ExtSelectClipRGN(dc: hdc; rgn : hrgn; Mode : Longint) : Integer;  override;}
 function ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean; override;
 
-function FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean; override;
+{function FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean; override;
 function FillRgn(DC: HDC; RegionHnd: HRGN; hbr: HBRUSH): Bool; override;
 function Frame(DC: HDC; const ARect: TRect): Integer; override;
 function Frame3d(DC: HDC; var ARect: TRect; const FrameWidth : integer; const Style : TBevelCut): Boolean; override;
@@ -114,9 +114,9 @@ function GetROP2(DC: HDC): Integer; override;
 function GetScrollBarSize(Handle: HWND; BarKind: Integer): integer; override;
 function GetScrollbarVisible(Handle: HWND; SBStyle: Integer): boolean; override;
 function GetScrollInfo(Handle: HWND; BarFlag: Integer; Var ScrollInfo: TScrollInfo): Boolean; override;
-function GetStockObject(Value: Integer): THandle; override;
+function GetStockObject(Value: Integer): THandle; override;}
 function GetSysColor(nIndex: Integer): DWORD; override;
-function GetSystemMetrics(nIndex: Integer): Integer; override;
+{function GetSystemMetrics(nIndex: Integer): Integer; override;
 function GetTextColor(DC: HDC) : TColorRef; Override;
 function GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer; var Size: TSize): Boolean; override;
 function GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean;  override;

lcl/interfaces/fpgui/fpguiwscontrols.pp

@@ -32,7 +32,7 @@ uses
   // LCL
   Controls, LCLType,
   // Widgetset
-  WSControls, WSLCLClasses;
+  fpguiproc, WSControls, WSLCLClasses;
 
 type
 
@@ -67,7 +67,7 @@ type
     class procedure SetPos(const AWinControl: TWinControl; const ALeft, ATop: Integer); override;
     class procedure SetSize(const AWinControl: TWinControl; const AWidth, AHeight: Integer); override;
     class procedure ShowHide(const AWinControl: TWinControl); override; //TODO: rename to SetVisible(control, visible)
-//    class procedure SetColor(const AWinControl: TWinControl); override;
+    class procedure SetColor(const AWinControl: TWinControl); override;
     class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override;
 
 {    class function  GetText(const AWinControl: TWinControl; var AText: String): Boolean; override;
@@ -138,9 +138,9 @@ end;
  ------------------------------------------------------------------------------}
 class procedure TFpGuiWSWinControl.DestroyHandle(const AWinControl: TWinControl);
 begin
-//  TFPGUIPrivateWidget(AWinControl.Handle).Free;
+  TFPGUIPrivateWidget(AWinControl.Handle).Free;
 
-//  AWinControl.Handle := 0;
+  AWinControl.Handle := 0;
 end;
 
 {------------------------------------------------------------------------------
@@ -223,6 +223,14 @@ begin
   FPWidget.Visible := not FPWidget.Visible;
 end;
 
+class procedure TFpGuiWSWinControl.SetColor(const AWinControl: TWinControl);
+var
+  FPWidget: TfpgWidget;
+begin
+  FPWidget := TFPGUIPrivateWidget(AWinControl.Handle).Widget;
+  FPWidget.BackgroundColor := TColorToTfpgColor(AWinControl.Color);
+end;
+
 {------------------------------------------------------------------------------
   Method: TFpGuiWSWinControl.SetCursor
   Params:  AWinControl     - the calling object

lcl/interfaces/fpgui/fpguiwsforms.pp

@@ -146,15 +146,14 @@ end;
   Returns: Nothing
  ------------------------------------------------------------------------------}
 class procedure TFpGuiWSCustomForm.DestroyHandle(const AWinControl: TWinControl);
-var
-  FPForm: TFPGUIPrivateWindow;
 begin
   {$ifdef VerboseFPGUIIntf}
     WriteLn('TFpGuiWSCustomForm.DestroyHandle');
   {$endif}
 
-  FPForm := TFPGUIPrivateWindow(AWinControl.Handle);
+  TFPGUIPrivateWindow(AWinControl.Handle).Free;
-  FPForm.Free;
+
+  AWinControl.Handle := 0;
 end;
 
 {------------------------------------------------------------------------------

lcl/interfaces/fpgui/fpguiwsprivate.pp

@@ -120,6 +120,7 @@ type
   private
     { Event Handlers }
     procedure PaintHandler(Sender: TObject{; const ARect: TfpgRect});
+    procedure CloseHandler(Sender: TObject; var CloseAction: TCloseAction);
   protected
   public
     { Constructors / Destructors }
@@ -291,7 +292,7 @@ end;
 
 destructor TFPGUIPrivateWidget.Destroy;
 begin
-  FreeAndNil(Widget);
+  if (Widget <> nil) then FreeAndNil(Widget);
 
   inherited Destroy;
 end;
@@ -409,6 +410,12 @@ begin
   end;
 end;
 
+procedure TFPGUIPrivateWindow.CloseHandler(Sender: TObject;
+  var CloseAction: TCloseAction);
+begin
+  CloseAction := caFree;
+end;
+
 {------------------------------------------------------------------------------
   Method: TFPGUIPrivateWindow.Create
   Params:  None
@@ -428,9 +435,10 @@ end;
  ------------------------------------------------------------------------------}
 procedure TFPGUIPrivateWindow.CreateWidget(const AParams: TCreateParams);
 begin
-{$IFDEF VerboseFPGUIPrivate}
+  {$IFDEF VerboseFPGUIPrivate}
     WriteLn('[TFPGUIPrivateWindow.CreateWidget]');
-{$ENDIF}
+  {$ENDIF}
+
   Widget := TfpgForm.Create(nil);
   Form.SetPosition(AParams.X, AParams.Y, AParams.Width, AParams.Height);
 end;
@@ -445,6 +453,7 @@ begin
   inherited SetEvents;
 
   Form.OnPaint := PaintHandler;
+  Form.OnClose := CloseHandler;
 end;
 
 {------------------------------------------------------------------------------
@@ -458,6 +467,15 @@ begin
   WriteLn('[TFPGUIPrivateWindow.Destroy]');
 {$ENDIF}
 
+  // Instead of destroying the form immediately, we call Close
+  // and set CloseAction to caFree in OnClose,
+  // which will do a delayed close
+  Form.Close;
+
+  // By setting the Widget to nil we prevent it's future
+  // destruction
+  Widget := nil;
+
   inherited Destroy;
 end;