mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-05 03:48:07 +02:00
363 lines
13 KiB
ObjectPascal
363 lines
13 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
InterfaceBase.pp
|
|
----------------
|
|
Initial Revision : Fri Jul 23 20:00:00 PDT 1999
|
|
|
|
|
|
***************************************************************************/
|
|
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
|
|
unit InterfaceBase;
|
|
|
|
{$mode objfpc}
|
|
{$LONGSTRINGS ON}
|
|
|
|
interface
|
|
|
|
{$ifdef Trace}
|
|
{$ASSERTIONS ON}
|
|
{$endif}
|
|
|
|
uses
|
|
Types, Classes, SysUtils, Math, FPImage,
|
|
// LCL
|
|
LCLProc, LCLType, LMessages, LCLPlatformDef, IntfGraphics, Themes, WSReferences,
|
|
// LazUtils
|
|
LazUTF8, IntegerList, LazUtilities, LazLoggerBase, GraphType, GraphMath, LazVersion;
|
|
|
|
type
|
|
PEventHandler = type Pointer;
|
|
PProcessEventHandler = type Pointer;
|
|
PPipeEventHandler = type Pointer;
|
|
PSocketEventHandler = type Pointer;
|
|
|
|
TChildExitReason = (cerExit, cerSignal);
|
|
TPipeReason = (prDataAvailable, prBroken, prCanWrite);
|
|
TPipeReasons = set of TPipeReason;
|
|
|
|
TApplicationMainLoop = procedure of object;
|
|
TWaitHandleEvent = procedure(AData: PtrInt; AFlags: dword) of object;
|
|
TChildExitEvent = procedure(AData: PtrInt; AReason: TChildExitReason; AInfo: dword) of object;
|
|
TPipeEvent = procedure(AData: PtrInt; AReasons: TPipeReasons) of object;
|
|
TSocketEvent = procedure(AData: PtrInt; AFlags: dword) of object;
|
|
|
|
TLCLWndMethod = procedure(var TheMessage: TLMessage) of Object;
|
|
|
|
TLCLCapability = (
|
|
lcAsyncProcess, // Support for async process
|
|
lcCanDrawOutsideOnPaint, // Support for drawing outside OnPaint event of an control
|
|
lcNeedMininimizeAppWithMainForm, // When main form is minimized, then minimize also app
|
|
lcApplicationTitle, // Can change application title in runtime
|
|
lcApplicationWindow, // Application has a special root window
|
|
lcFormIcon, // Forms have icon
|
|
lcModalWindow, // native modal windows support
|
|
lcDragDockStartOnTitleClick,// ability to start drag/dock events on title bar click
|
|
lcAntialiasingEnabledByDefault, // is amDontCare = amOn for the widgetset
|
|
lcLMHelpSupport, // support for LM_HELP command
|
|
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
|
|
lcSendsUTF8KeyPress, // If the interface does not yet send UTF8KeyPress directly, then it will be emulated in TWinControl.CNChar
|
|
lcAllowChildControlsInNativeControls, // Utilized by LCL-CustomDrawn so that it can inject child controls in native ones
|
|
lcEmulatedMDI, // used for emulating MDI on widgetsets which does not provide native MDI handling
|
|
lcAccessibilitySupport, // Indicates that accessibility is implemented, mostly for TCustomControl descendents as native widgests should have in-built accessibility
|
|
lcRadialGradientBrush, // Indicates that the function CreateBrushWithRadialGradient is supported, i.e. we can create a brush with a radial gradient pattern
|
|
lcTransparentWindow, // ability to pass mouse messages through a window (on win32 LM_NCHITTEST with HTTRANSPARENT result)
|
|
lcTextHint, // native TextHint support
|
|
lcNativeTaskDialog, // task dialog under mswindows for widgetsets different than win32/wince. Used in LCLTaskDialog. eg Qt/Qt5 must set this option to false otherwise taskdialog segfaults.
|
|
lcCanDrawHidden, // the system rendering engine might request a hidden control to be drawn (macOS 10.9 and later)
|
|
lcAccelleratorKeys // the system supports UI concept of &-like notation
|
|
);
|
|
|
|
{ TDialogButton }
|
|
|
|
TDialogButton = class(TCollectionItem)
|
|
private
|
|
FCaption: string;
|
|
FModalResult: LongInt;
|
|
function GetCancel: Boolean;
|
|
function GetDefault: Boolean;
|
|
procedure SetCancel(const AValue: Boolean);
|
|
procedure SetDefault(const AValue: Boolean);
|
|
protected
|
|
function GetDisplayName: string; override;
|
|
procedure SetCaption(const AValue: string); virtual;
|
|
public
|
|
constructor Create(ACollection: TCollection); override;
|
|
property Caption: string read FCaption write SetCaption;
|
|
property Cancel: Boolean read GetCancel write SetCancel;
|
|
property Default: Boolean read GetDefault write SetDefault;
|
|
property ModalResult: LongInt read FModalResult write FModalResult;
|
|
end;
|
|
|
|
{ TDialogButtons }
|
|
|
|
TDialogButtons = class(TCollection)
|
|
protected
|
|
FCancelButton: TDialogButton;
|
|
FDefaultButton: TDialogButton;
|
|
function GetItem(Index: Integer): TDialogButton;
|
|
procedure SetCancelButton(const AValue: TDialogButton); virtual;
|
|
procedure SetDefaultButton(const Value: TDialogButton); virtual;
|
|
procedure SetItem(Index: Integer; const Value: TDialogButton);
|
|
public
|
|
destructor Destroy; override;
|
|
function Add: TDialogButton;
|
|
function FindButton(AModalResult: LongInt): TDialogButton;
|
|
function FindButton(Order: array of LongInt): TDialogButton;
|
|
property DefaultButton: TDialogButton read FDefaultButton write SetDefaultButton;
|
|
property CancelButton: TDialogButton read FCancelButton write SetCancelButton;
|
|
property Items[Index: Integer]: TDialogButton read GetItem write SetItem; default;
|
|
end;
|
|
|
|
type
|
|
TWSTimerProc = procedure of object;
|
|
|
|
{ TWidgetSet }
|
|
|
|
TWidgetSet = class(TObject)
|
|
protected
|
|
FThemeServices: TThemeServices;
|
|
procedure PassCmdLineOptions; virtual;
|
|
function CreateThemeServices: TThemeServices; virtual;
|
|
function GetAppHandle: TLCLHandle; virtual;
|
|
procedure SetAppHandle(const AValue: TLCLHandle); virtual;
|
|
public
|
|
constructor Create; virtual;
|
|
procedure BeforeDestruction; override;
|
|
|
|
procedure AppInit(var ScreenInfo: TScreenInfo); virtual; abstract;
|
|
procedure AppRun(const ALoop: TApplicationMainLoop); virtual;
|
|
procedure AppWaitMessage; virtual; abstract;
|
|
procedure AppProcessMessages; virtual; abstract;
|
|
procedure AppTerminate; virtual; abstract;
|
|
procedure AppMinimize; virtual; abstract;
|
|
procedure AppRestore; virtual; abstract;
|
|
procedure AppBringToFront; virtual; abstract;
|
|
procedure AppSetIcon(const Small, Big: HICON); virtual;
|
|
procedure AppSetTitle(const ATitle: string); virtual;
|
|
procedure AppSetVisible(const AVisible: Boolean); virtual;
|
|
function AppRemoveStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; virtual;
|
|
function AppRestoreStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; virtual;
|
|
procedure AppSetMainFormOnTaskBar(const DoSet: Boolean); virtual;
|
|
procedure AppSetupMainForm(AMainForm: TObject); virtual;
|
|
|
|
// Begin/End processing messages, which can be used to acquire/release
|
|
// resources during message processing.
|
|
// for example, on Cocoa, it needs to be used to release AutoReleasePool
|
|
// to avoid resource leaks.
|
|
function BeginMessageProcess: TLCLHandle; virtual;
|
|
procedure EndMessageProcess(context: TLCLHandle); virtual;
|
|
|
|
function LCLPlatform: TLCLPlatform; virtual; abstract;
|
|
function GetLCLCapability(ACapability: TLCLCapability): PtrUInt; virtual;
|
|
|
|
function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; virtual; abstract;
|
|
procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); virtual; abstract;
|
|
procedure DCRedraw(CanvasHandle: HDC); virtual; abstract;
|
|
procedure DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean); virtual;
|
|
procedure SetDesigning(AComponent: TComponent); virtual;
|
|
|
|
function InitStockFont(AFont: TObject; AStockFont: TStockFont): Boolean; virtual;
|
|
function IsHelpKey(Key: Word; Shift: TShiftState): Boolean; virtual;
|
|
|
|
// create and destroy
|
|
function CreateTimer(Interval: integer; TimerProc: TWSTimerProc): TLCLHandle; virtual; abstract;
|
|
function DestroyTimer(TimerHandle: TLCLHandle): boolean; virtual; abstract;
|
|
property AppHandle: TLCLHandle read GetAppHandle write SetAppHandle; platform;
|
|
|
|
{$DEFINE IF_BASE_MEMBER}
|
|
{$I winapih.inc}
|
|
{$I lclintfh.inc}
|
|
{$UNDEF IF_BASE_MEMBER}
|
|
|
|
property ThemeServices: TThemeServices read FThemeServices;
|
|
end;
|
|
TWidgetSetClass = class of TWidgetSet;
|
|
|
|
{ TMessageDispatcher }
|
|
|
|
TMessageDispatcher = class
|
|
private
|
|
FMethod: TLCLWndMethod;
|
|
public
|
|
constructor Create(AMethod: TLCLWndMethod);
|
|
procedure Dispatch(var message); override;
|
|
end;
|
|
|
|
function GetDefaultLCLWidgetType: TLCLPlatform;
|
|
function GetLCLWidgetTypeName: string;
|
|
|
|
function MemSizeLessThan(AMemSize, AThen: PtrUInt): Boolean; inline;
|
|
|
|
const
|
|
{ Constants for the routine TWidgetSet.GetLCLCapability }
|
|
LCL_CAPABILITY_NO = 0;
|
|
LCL_CAPABILITY_YES = 1;
|
|
|
|
type
|
|
EInterfaceException = class(Exception);
|
|
EInterfaceError = class(EInterfaceException);
|
|
EInterfaceCritical = class(EInterfaceException);
|
|
EInterfaceWarning = class(EInterfaceException);
|
|
|
|
type
|
|
TInputDialogFunction = function (const InputCaption, InputPrompt : String;
|
|
MaskInput : Boolean; var Value : String) : Boolean;
|
|
TPromptDialogFunction = function(const DialogCaption, DialogMessage : String;
|
|
DialogType : longint; Buttons : PLongint;
|
|
ButtonCount, DefaultIndex, EscapeResult : Longint;
|
|
UseDefaultPos: boolean;
|
|
X, Y : Longint) : Longint;
|
|
TQuestionDialogFunction = function(const aCaption, aMsg: string;
|
|
DlgType: LongInt; Buttons: TDialogButtons; HelpCtx: Longint): LongInt;
|
|
TLoadBitmapFunction = function(hInstance: TLCLHandle; lpBitmapName: PChar): HBitmap;
|
|
TLoadCursorFunction = function(hInstance: TLCLHandle; lpCursorName: PChar): HCursor;
|
|
TLoadIconFunction = function(hInstance: TLCLHandle; lpIconName: PChar): HIcon;
|
|
|
|
var
|
|
InputDialogFunction: TInputDialogFunction = nil;
|
|
PromptDialogFunction: TPromptDialogFunction = nil;
|
|
QuestionDialogFunction: TQuestionDialogFunction = nil;
|
|
LoadBitmapFunction: TLoadBitmapFunction = nil;
|
|
LoadCursorFunction: TLoadCursorFunction = nil;
|
|
LoadIconFunction: TLoadIconFunction = nil;
|
|
|
|
var
|
|
WidgetSet: TWidgetSet = nil;
|
|
|
|
implementation
|
|
|
|
function GetDefaultLCLWidgetType: TLCLPlatform;
|
|
begin
|
|
if (WidgetSet<>nil) and (WidgetSet.LCLPlatform<>lpNoGUI) then
|
|
Result:=WidgetSet.LCLPlatform
|
|
else
|
|
Result:=BuildLCLWidgetType;
|
|
end;
|
|
|
|
function GetLCLWidgetTypeName: string;
|
|
begin
|
|
Result:=LCLPlatformDirNames[GetDefaultLCLWidgetType];
|
|
end;
|
|
|
|
function MemSizeLessThan(AMemSize, AThen: PtrUInt): Boolean; inline;
|
|
begin
|
|
Result:=(AMemSize<>0) and (AMemSize<AThen);
|
|
end;
|
|
|
|
{ TDialogButtons }
|
|
|
|
procedure TDialogButtons.SetCancelButton(const AValue: TDialogButton);
|
|
begin
|
|
FCancelButton := AValue;
|
|
end;
|
|
|
|
function TDialogButtons.GetItem(Index: Integer): TDialogButton;
|
|
begin
|
|
Result := TDialogButton(inherited GetItem(Index));
|
|
end;
|
|
|
|
procedure TDialogButtons.SetDefaultButton(const Value: TDialogButton);
|
|
begin
|
|
FDefaultButton := Value;
|
|
end;
|
|
|
|
procedure TDialogButtons.SetItem(Index: Integer; const Value: TDialogButton);
|
|
begin
|
|
inherited SetItem(Index, Value);
|
|
end;
|
|
|
|
destructor TDialogButtons.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TDialogButtons.Add: TDialogButton;
|
|
begin
|
|
Result := TDialogButton(inherited Add);
|
|
end;
|
|
|
|
function TDialogButtons.FindButton(AModalResult: LongInt): TDialogButton;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to Count - 1 do
|
|
if Items[i].ModalResult = AModalResult then
|
|
Exit(Items[i]);
|
|
Result := nil;
|
|
end;
|
|
|
|
function TDialogButtons.FindButton(Order: array of LongInt): TDialogButton;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := Low(Order) to High(Order) do
|
|
begin
|
|
Result := FindButton(Order[i]);
|
|
if Result <> nil then
|
|
Exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
{ TDialogButton }
|
|
|
|
procedure TDialogButton.SetCaption(const AValue: string);
|
|
begin
|
|
FCaption := AValue;
|
|
end;
|
|
|
|
function TDialogButton.GetDefault: Boolean;
|
|
begin
|
|
Result := TDialogButtons(Collection).DefaultButton = Self;
|
|
end;
|
|
|
|
function TDialogButton.GetCancel: Boolean;
|
|
begin
|
|
Result := TDialogButtons(Collection).CancelButton = Self;
|
|
end;
|
|
|
|
procedure TDialogButton.SetCancel(const AValue: Boolean);
|
|
begin
|
|
if AValue then
|
|
TDialogButtons(Collection).CancelButton := Self
|
|
else
|
|
TDialogButtons(Collection).CancelButton := nil;
|
|
end;
|
|
|
|
procedure TDialogButton.SetDefault(const AValue: Boolean);
|
|
begin
|
|
if AValue then
|
|
TDialogButtons(Collection).DefaultButton := Self
|
|
else
|
|
TDialogButtons(Collection).DefaultButton := nil;
|
|
end;
|
|
|
|
function TDialogButton.GetDisplayName: string;
|
|
begin
|
|
Result := FCaption;
|
|
end;
|
|
|
|
constructor TDialogButton.Create(ACollection: TCollection);
|
|
begin
|
|
inherited Create(ACollection);
|
|
FCaption := '';
|
|
FModalResult := 0;
|
|
end;
|
|
|
|
{$I interfacebase.inc}
|
|
{$I intfbasewinapi.inc}
|
|
{$I intfbaselcl.inc}
|
|
|
|
initialization
|
|
LazVersion.OnLCLWidgetTypeName := @GetLCLWidgetTypeName;
|
|
|
|
end.
|