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