1{
2 /***************************************************************************
3                               InterfaceBase.pp
4                               ----------------
5                   Initial Revision  : Fri Jul 23 20:00:00 PDT 1999
6
7
8 ***************************************************************************/
9
10 *****************************************************************************
11  This file is part of the Lazarus Component Library (LCL)
12
13  See the file COPYING.modifiedLGPL.txt, included in this distribution,
14  for details about the license.
15 *****************************************************************************
16}
17
18unit InterfaceBase;
19
20{$mode objfpc}
21{$LONGSTRINGS ON}
22
23interface
24
25{$ifdef Trace}
26  {$ASSERTIONS ON}
27{$endif}
28
29uses
30  Types, Classes, SysUtils, Math, FPImage,
31  // LazUtils
32  LazUTF8, IntegerList,
33  // LCL
34  LCLType, LCLProc, LMessages, LCLPlatformDef,
35  GraphType, GraphMath, IntfGraphics, Themes;
36
37type
38  PEventHandler = type Pointer;
39  PProcessEventHandler = type Pointer;
40  PPipeEventHandler = type Pointer;
41  PSocketEventHandler = type Pointer;
42
43  TChildExitReason = (cerExit, cerSignal);
44  TPipeReason = (prDataAvailable, prBroken, prCanWrite);
45  TPipeReasons = set of TPipeReason;
46
47  TApplicationMainLoop = procedure of object;
48  TWaitHandleEvent = procedure(AData: PtrInt; AFlags: dword) of object;
49  TChildExitEvent = procedure(AData: PtrInt; AReason: TChildExitReason; AInfo: dword) of object;
50  TPipeEvent = procedure(AData: PtrInt; AReasons: TPipeReasons) of object;
51  TSocketEvent = procedure(AData: PtrInt; AFlags: dword) of object;
52
53  TLCLWndMethod = procedure(var TheMessage: TLMessage) of Object;
54
55  TLCLCapability = (
56    lcAsyncProcess,             // Support for async process
57    lcCanDrawOutsideOnPaint,    // Support for drawing outside OnPaint event of an control
58    lcNeedMininimizeAppWithMainForm, // When main form is minimized, then minimize also app
59    lcApplicationTitle,         // Can change application title in runtime
60    lcApplicationWindow,        // Application has a special root window
61    lcFormIcon,                 // Forms have icon
62    lcModalWindow,              // native modal windows support
63    lcDragDockStartOnTitleClick,// ability to start drag/dock events on title bar click
64    lcAntialiasingEnabledByDefault, // is amDontCare = amOn for the widgetset
65    lcLMHelpSupport,            // support for LM_HELP command
66    lcReceivesLMClearCutCopyPasteReliably, // In Carbon we do not receive LM_CLEAR, CUT, COPY, PASTE, etc reliably, and this affects DB controls. See bug http://bugs.freepascal.org/view.php?id=20394
67    lcSendsUTF8KeyPress,        // If the interface does not yet send UTF8KeyPress directly, then it will be emulated in TWinControl.CNChar
68    lcAllowChildControlsInNativeControls, // Utilized by LCL-CustomDrawn so that it can inject child controls in native ones
69    lcEmulatedMDI, // used for emulating MDI on widgetsets which does not provide native MDI handling
70    lcAccessibilitySupport,     // Indicates that accessibility is implemented, mostly for TCustomControl descendents as native widgests should have in-built accessibility
71    lcRadialGradientBrush,      // Indicates that the function CreateBrushWithRadialGradient is supported, i.e. we can create a brush with a radial gradient pattern
72    lcTransparentWindow,        // ability to pass mouse messages through a window (on win32 LM_NCHITTEST with HTTRANSPARENT result)
73    lcTextHint                  // native TextHint support
74  );
75
76  { TDialogButton }
77
78  TDialogButton = class(TCollectionItem)
79  private
80    FCaption: string;
81    FModalResult: LongInt;
82    function GetCancel: Boolean;
83    function GetDefault: Boolean;
84    procedure SetCancel(const AValue: Boolean);
85    procedure SetDefault(const AValue: Boolean);
86  protected
87    function GetDisplayName: string; override;
88    procedure SetCaption(const AValue: string); virtual;
89  public
90    constructor Create(ACollection: TCollection); override;
91    property Caption: string read FCaption write SetCaption;
92    property Cancel: Boolean read GetCancel write SetCancel;
93    property Default: Boolean read GetDefault write SetDefault;
94    property ModalResult: LongInt read FModalResult write FModalResult;
95  end;
96
97  { TDialogButtons }
98
99  TDialogButtons = class(TCollection)
100  protected
101    FCancelButton: TDialogButton;
102    FDefaultButton: TDialogButton;
103    function GetItem(Index: Integer): TDialogButton;
104    procedure SetCancelButton(const AValue: TDialogButton); virtual;
105    procedure SetDefaultButton(const Value: TDialogButton); virtual;
106    procedure SetItem(Index: Integer; const Value: TDialogButton);
107  public
108    destructor Destroy; override;
109    function Add: TDialogButton;
110    function FindButton(AModalResult: LongInt): TDialogButton;
111    function FindButton(Order: array of LongInt): TDialogButton;
112    property DefaultButton: TDialogButton read FDefaultButton write SetDefaultButton;
113    property CancelButton: TDialogButton read FCancelButton write SetCancelButton;
114    property Items[Index: Integer]: TDialogButton read GetItem write SetItem; default;
115  end;
116
117type
118  TWSTimerProc = procedure of object;
119
120  { TWidgetSet }
121
122  TWidgetSet = class(TObject)
123  protected
124    FThemeServices: TThemeServices;
125    procedure PassCmdLineOptions; virtual;
126    function CreateThemeServices: TThemeServices; virtual;
127    function GetAppHandle: THandle; virtual;
128    procedure SetAppHandle(const AValue: THandle); virtual;
129  public
130    constructor Create; virtual;
131    procedure BeforeDestruction;override;
132
133    procedure AppInit(var ScreenInfo: TScreenInfo); virtual; abstract;
134    procedure AppRun(const ALoop: TApplicationMainLoop); virtual;
135    procedure AppWaitMessage; virtual; abstract;
136    procedure AppProcessMessages; virtual; abstract;
137    procedure AppTerminate; virtual; abstract;
138    procedure AppMinimize; virtual; abstract;
139    procedure AppRestore; virtual; abstract;
140    procedure AppBringToFront; virtual; abstract;
141    procedure AppSetIcon(const Small, Big: HICON); virtual;
142    procedure AppSetTitle(const ATitle: string); virtual;
143    procedure AppSetVisible(const AVisible: Boolean); virtual;
144    function AppRemoveStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; virtual;
145    function AppRestoreStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; virtual;
146    procedure AppSetMainFormOnTaskBar(const DoSet: Boolean); virtual;
147
148    function  LCLPlatform: TLCLPlatform; virtual; abstract;
149    function  GetLCLCapability(ACapability: TLCLCapability): PtrUInt; virtual;
150
151    function  DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; virtual; abstract;
152    procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); virtual; abstract;
153    procedure DCRedraw(CanvasHandle: HDC); virtual; abstract;
154    procedure DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean); virtual;
155    procedure SetDesigning(AComponent: TComponent); virtual;
156
157    function  InitStockFont(AFont: TObject; AStockFont: TStockFont): Boolean; virtual;
158    function  IsHelpKey(Key: Word; Shift: TShiftState): Boolean; virtual;
159
160    // create and destroy
161    function CreateTimer(Interval: integer; TimerProc: TWSTimerProc): THandle; virtual; abstract;
162    function DestroyTimer(TimerHandle: THandle): boolean; virtual; abstract;
163    property AppHandle: THandle read GetAppHandle write SetAppHandle; platform;
164
165    {$DEFINE IF_BASE_MEMBER}
166    {$I winapih.inc}
167    {$I lclintfh.inc}
168    {$UNDEF IF_BASE_MEMBER}
169
170    property ThemeServices: TThemeServices read FThemeServices;
171  end;
172  TWidgetSetClass = class of TWidgetSet;
173
174  function GetDefaultLCLWidgetType: TLCLPlatform;
175  function GetLCLWidgetTypeName: string;
176
177const
178  { Constants for the routine TWidgetSet.GetLCLCapability }
179  LCL_CAPABILITY_NO = 0;
180  LCL_CAPABILITY_YES = 1;
181
182type
183  EInterfaceException = class(Exception);
184  EInterfaceError = class(EInterfaceException);
185  EInterfaceCritical = class(EInterfaceException);
186  EInterfaceWarning = class(EInterfaceException);
187
188type
189  TInputDialogFunction = function (const InputCaption, InputPrompt : String;
190                             MaskInput : Boolean; var Value : String) : Boolean;
191  TPromptDialogFunction = function(const DialogCaption, DialogMessage : String;
192    DialogType : longint; Buttons : PLongint;
193    ButtonCount, DefaultIndex, EscapeResult : Longint;
194    UseDefaultPos: boolean;
195    X, Y : Longint) : Longint;
196  TQuestionDialogFunction = function(const aCaption, aMsg: string;
197    DlgType: LongInt; Buttons: TDialogButtons; HelpCtx: Longint): LongInt;
198  TLoadBitmapFunction = function(hInstance: THandle; lpBitmapName: PChar): HBitmap;
199  TLoadCursorFunction = function(hInstance: THandle; lpCursorName: PChar): HCursor;
200  TLoadIconFunction= function(hInstance: THandle; lpIconName: PChar): HIcon;
201
202var
203  InputDialogFunction: TInputDialogFunction = nil;
204  PromptDialogFunction: TPromptDialogFunction = nil;
205  QuestionDialogFunction: TQuestionDialogFunction = nil;
206  LoadBitmapFunction: TLoadBitmapFunction = nil;
207  LoadCursorFunction: TLoadCursorFunction = nil;
208  LoadIconFunction: TLoadIconFunction = nil;
209
210var
211  WidgetSet: TWidgetSet = nil;
212
213implementation
214
215{function GetDefaultLCLWidgetType: TLCLPlatform;
216begin
217  Assert(Assigned(WidgetSet), 'GetDefaultLCLWidgetType: WidgetSet is not assigned.');
218  if WidgetSet.LCLPlatform<>lpNoGUI then
219    Result:=WidgetSet.LCLPlatform
220end; }
221function GetDefaultLCLWidgetType: TLCLPlatform;
222begin
223  if (WidgetSet<>nil) and (WidgetSet.LCLPlatform<>lpNoGUI) then
224    Result:=WidgetSet.LCLPlatform
225  else
226    Result:=BuildLCLWidgetType;
227end;
228
229function GetLCLWidgetTypeName: string;
230begin
231  Result:=LCLPlatformDirNames[GetDefaultLCLWidgetType];
232end;
233
234{ TDialogButtons }
235
236procedure TDialogButtons.SetCancelButton(const AValue: TDialogButton);
237begin
238  FCancelButton := AValue;
239end;
240
241function TDialogButtons.GetItem(Index: Integer): TDialogButton;
242begin
243  Result := TDialogButton(inherited GetItem(Index));
244end;
245
246procedure TDialogButtons.SetDefaultButton(const Value: TDialogButton);
247begin
248  FDefaultButton := Value;
249end;
250
251procedure TDialogButtons.SetItem(Index: Integer; const Value: TDialogButton);
252begin
253  inherited SetItem(Index, Value);
254end;
255
256destructor TDialogButtons.Destroy;
257begin
258  inherited Destroy;
259end;
260
261function TDialogButtons.Add: TDialogButton;
262begin
263  Result := TDialogButton(inherited Add);
264end;
265
266function TDialogButtons.FindButton(AModalResult: LongInt): TDialogButton;
267var
268  i: Integer;
269begin
270  for i := 0 to Count - 1 do
271    if Items[i].ModalResult = AModalResult then
272      Exit(Items[i]);
273  Result := nil;
274end;
275
276function TDialogButtons.FindButton(Order: array of LongInt): TDialogButton;
277var
278  i: Integer;
279begin
280  for i := Low(Order) to High(Order) do
281  begin
282    Result := FindButton(Order[i]);
283    if Result <> nil then
284      Exit;
285  end;
286  Result := nil;
287end;
288
289{ TDialogButton }
290
291procedure TDialogButton.SetCaption(const AValue: string);
292begin
293  FCaption := AValue;
294end;
295
296function TDialogButton.GetDefault: Boolean;
297begin
298  Result := TDialogButtons(Collection).DefaultButton = Self;
299end;
300
301function TDialogButton.GetCancel: Boolean;
302begin
303  Result := TDialogButtons(Collection).CancelButton = Self;
304end;
305
306procedure TDialogButton.SetCancel(const AValue: Boolean);
307begin
308  if AValue then
309    TDialogButtons(Collection).CancelButton := Self
310  else
311    TDialogButtons(Collection).CancelButton := nil;
312end;
313
314procedure TDialogButton.SetDefault(const AValue: Boolean);
315begin
316  if AValue then
317    TDialogButtons(Collection).DefaultButton := Self
318  else
319    TDialogButtons(Collection).DefaultButton := nil;
320end;
321
322function TDialogButton.GetDisplayName: string;
323begin
324  Result := FCaption;
325end;
326
327constructor TDialogButton.Create(ACollection: TCollection);
328begin
329  inherited Create(ACollection);
330  FCaption := '';
331  FModalResult := 0;
332end;
333
334{$I interfacebase.inc}
335{$I intfbasewinapi.inc}
336{$I intfbaselcl.inc}
337
338end.
339