mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-09 19:08:03 +02:00
TApplication now descends from TCustomApplication
git-svn-id: trunk@4471 -
This commit is contained in:
mattias
parent
2476a3797b
commit
e691fb61ec
48
lcl/forms.pp
48
lcl/forms.pp
@ -43,7 +43,9 @@ interface
|
||||
uses
|
||||
Classes, Controls, LCLStrConsts, VCLGlobals, SysUtils, LCLType, LCLProc,
|
||||
LCLLinux, InterfaceBase, GraphType, Graphics, Menus, LMessages, CustomTimer,
|
||||
ActnList, ClipBrd;
|
||||
ActnList, ClipBrd
|
||||
{$IFDEF UseCustApp},CustApp{$ENDIF}
|
||||
;
|
||||
|
||||
type
|
||||
TProcedure = procedure;
|
||||
@ -654,13 +656,15 @@ type
|
||||
);
|
||||
TApplicationFlags = set of TApplicationFlag;
|
||||
|
||||
{$IFDEF UseCustApp}
|
||||
TApplication = class(TCustomApplication)
|
||||
{$ELSE}
|
||||
TApplication = class(TComponent)
|
||||
{$ENDIF}
|
||||
private
|
||||
FCaptureExceptions: boolean;
|
||||
FFlags: TApplicationFlags;
|
||||
FHandle : THandle;
|
||||
//FHelpSystem : IHelpSystem;
|
||||
FHelpFile: string;
|
||||
FHint: string;
|
||||
FHintColor: TColor;
|
||||
FHintControl: TControl;
|
||||
@ -676,7 +680,6 @@ type
|
||||
FMainForm : TForm;
|
||||
FMouseControl: TControl;
|
||||
FOldExceptProc: TExceptProc;
|
||||
FOnException: TExceptionEvent;
|
||||
FOnHelp: THelpEvent;
|
||||
FOnHint: TNotifyEvent;
|
||||
FOnIdle: TIdleEvent;
|
||||
@ -688,8 +691,12 @@ type
|
||||
FOnUserInput: TOnUserInputEvent;
|
||||
FOnUserInputHandler: TMethodList;
|
||||
FShowHint: Boolean;
|
||||
{$IFNDEF UseCustApp}
|
||||
FHelpFile: string;
|
||||
FTerminate : Boolean;
|
||||
FTitle : String;
|
||||
FOnException: TExceptionEvent;
|
||||
{$ENDIF}
|
||||
procedure DoOnIdleEnd;
|
||||
function GetCurrentHelpFile: string;
|
||||
function GetExename: String;
|
||||
@ -708,13 +715,17 @@ type
|
||||
function ValidateHelpSystem: Boolean;
|
||||
procedure WndProc(var AMessage : TLMessage);
|
||||
protected
|
||||
{$IFDEF UseCustApp}
|
||||
Function GetConsoleApplication: boolean; override;
|
||||
{$ENDIF}
|
||||
procedure NotifyIdleHandler;
|
||||
procedure NotifyIdleEndHandler;
|
||||
function IsHintMsg(var Msg: TMsg): Boolean;
|
||||
procedure DoOnMouseMove; virtual;
|
||||
procedure ShowHintWindow(const Info: THintInfoAtMouse);
|
||||
procedure StartHintTimer(Interval: integer; TimerType: TAppHintTimerType);
|
||||
procedure OnHintTimer(Sender: TObject);
|
||||
procedure SetTitle(const AValue: String); {$IFDEF UseCustApp}override;{$ENDIF}
|
||||
procedure StartHintTimer(Interval: integer; TimerType: TAppHintTimerType);
|
||||
procedure UpdateVisible;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
@ -723,7 +734,7 @@ type
|
||||
Procedure BringToFront;
|
||||
procedure CreateForm(InstanceClass: TComponentClass; var Reference);
|
||||
function HandleAllocated: boolean;
|
||||
procedure HandleException(Sender: TObject);
|
||||
procedure HandleException(Sender: TObject); {$IFDEF UseCustApp}override;{$ENDIF}
|
||||
procedure HandleMessage;
|
||||
function HelpCommand(Command: Integer; Data: Longint): Boolean;
|
||||
function HelpContext(Context: THelpContext): Boolean;
|
||||
@ -735,13 +746,13 @@ type
|
||||
procedure HideHint;
|
||||
procedure HintMouseMessage(Control : TControl; var AMessage: TLMessage);
|
||||
property Icon: TIcon read FIcon write SetIcon;
|
||||
procedure Initialize;
|
||||
function MessageBox(Text, Caption : PChar; Flags : Longint) : Integer;
|
||||
procedure Notification(AComponent : TComponent; Operation : TOperation); override;
|
||||
procedure Initialize; {$IFDEF UseCustApp}override;{$ENDIF}
|
||||
function MessageBox(Text, Caption: PChar; Flags: Longint): Integer;
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
Procedure ProcessMessages;
|
||||
procedure Run;
|
||||
procedure ShowException(E: Exception);
|
||||
procedure Terminate;
|
||||
procedure ShowException(E: Exception); {$IFDEF UseCustApp}override;{$ENDIF}
|
||||
procedure Terminate; {$IFDEF UseCustApp}override;{$ENDIF}
|
||||
procedure NotifyUserInputHandler(Msg: Cardinal);
|
||||
procedure NotifyKeyDownHandler(Sender: TObject;
|
||||
var Key : Word; Shift : TShiftState);
|
||||
@ -755,10 +766,10 @@ type
|
||||
procedure RemoveOnKeyDownHandler(AnOnKeyDownHandler: TKeyEvent);
|
||||
procedure DoBeforeMouseMessage(CurMouseControl: TControl);
|
||||
public
|
||||
property Exename: String read GetExeName;
|
||||
property CaptureExceptions: boolean read FCaptureExceptions
|
||||
write SetCaptureExceptions;
|
||||
property Handle: THandle read FHandle;
|
||||
//property HelpSystem : IHelpSystem read FHelpSystem;
|
||||
property HelpFile: string read FHelpFile write FHelpFile;
|
||||
property Hint: string read FHint write SetHint;
|
||||
property HintColor: TColor read FHintColor write SetHintColor;
|
||||
property HintHidePause: Integer read FHintHidePause write FHintHidePause;
|
||||
@ -766,8 +777,6 @@ type
|
||||
property HintShortCuts: Boolean read FHintShortCuts write FHintShortCuts;
|
||||
property HintShortPause: Integer read FHintShortPause write FHintShortPause;
|
||||
property MainForm: TForm read FMainForm;
|
||||
property Terminated: Boolean read FTerminate;
|
||||
property OnException: TExceptionEvent read FOnException write FOnException;
|
||||
property OnIdle: TIdleEvent read FOnIdle write FOnIdle;
|
||||
property OnIdleEnd: TNotifyEvent read FOnIdleEnd write FOnIdleEnd;
|
||||
property OnHelp: THelpEvent read FOnHelp write FOnHelp;
|
||||
@ -775,8 +784,13 @@ type
|
||||
property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
|
||||
property OnUserInput: TOnUserInputEvent read FOnUserInput write FOnUserInput;
|
||||
property ShowHint: Boolean read FShowHint write SetShowHint;
|
||||
property Title: String read GetTitle write FTitle;
|
||||
property CaptureExceptions: boolean read FCaptureExceptions write SetCaptureExceptions;
|
||||
property Title: String read GetTitle write SetTitle;
|
||||
{$IFNDEF UseCustApp}
|
||||
property Exename: String read GetExeName;
|
||||
property HelpFile: string read FHelpFile write FHelpFile;
|
||||
property Terminated: Boolean read FTerminate;
|
||||
property OnException: TExceptionEvent read FOnException write FOnException;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
@ -73,7 +73,6 @@ begin
|
||||
Focusmessages := True;
|
||||
LCLProc.SendApplicationMessageFunction:=@SendApplicationMsg;
|
||||
|
||||
FTerminate := False;
|
||||
FMainForm := nil;
|
||||
FMouseControl := nil;
|
||||
FHandle := 0;
|
||||
@ -111,6 +110,7 @@ begin
|
||||
FreeThenNil(FOnKeyDownHandler);
|
||||
inherited Destroy;
|
||||
|
||||
// restore exception handling
|
||||
CaptureExceptions:=false;
|
||||
LCLProc.SendApplicationMessageFunction:=nil;
|
||||
end;
|
||||
@ -210,6 +210,9 @@ end;
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TApplication.Initialize;
|
||||
begin
|
||||
{$IFDEF UseCustApp}
|
||||
inherited Initialize;
|
||||
{$ENDIF}
|
||||
// interface object and screen
|
||||
if (InterfaceObject=nil)
|
||||
or (AnsiCompareText(InterfaceObject.Classname,'TINTERFACEBASE')=0) then begin
|
||||
@ -337,7 +340,7 @@ begin
|
||||
// Command, Data);
|
||||
end
|
||||
else
|
||||
if FHelpFile <> '' then
|
||||
if HelpFile <> '' then
|
||||
begin
|
||||
//HelpHandle := Handle;
|
||||
//if FMainForm <> nil then HelpHandle := FMainForm.Handle;
|
||||
@ -379,6 +382,17 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
procedure TApplication.SetTitle(const AValue: String);
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TApplication.SetTitle(const AValue: String);
|
||||
begin
|
||||
{$IFDEF UseCustApp}
|
||||
inherited SetTitle(AValue);
|
||||
{$ENDIF}
|
||||
// ToDo: tell the interface
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
procedure TApplication.StopHintTimer;
|
||||
------------------------------------------------------------------------------}
|
||||
@ -648,16 +662,15 @@ end;
|
||||
------------------------------------------------------------------------------}
|
||||
function TApplication.GetTitle: string;
|
||||
var
|
||||
ext : string;
|
||||
Ext: string;
|
||||
begin
|
||||
If FTitle = '' then begin
|
||||
Result := Title;
|
||||
If Result = '' then begin
|
||||
Result := ExtractFileName(GetExeName);
|
||||
Ext := ExtractFileExt(Result);
|
||||
If Ext <> '' then
|
||||
Delete(Result, Length(Result) - Length(Ext) + 1, Length(Ext));
|
||||
end
|
||||
else
|
||||
Result := FTitle;
|
||||
end;
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
@ -678,6 +691,10 @@ begin
|
||||
Halt;
|
||||
end;
|
||||
Include(FFlags,AppHandlingException);
|
||||
{$IFDEF UseCustApp}
|
||||
if StopOnException then
|
||||
inherited Terminate;
|
||||
{$ENDIF}
|
||||
// before we do anything, write it down
|
||||
if ExceptObject is Exception then begin
|
||||
writeln('TApplication.HandleException ',Exception(ExceptObject).Message);
|
||||
@ -691,8 +708,8 @@ begin
|
||||
// handle the exception
|
||||
if ExceptObject is Exception then begin
|
||||
if not (ExceptObject is EAbort) then
|
||||
if Assigned(FOnException) then
|
||||
FOnException(Sender, Exception(ExceptObject))
|
||||
if Assigned(OnException) then
|
||||
OnException(Sender, Exception(ExceptObject))
|
||||
else
|
||||
ShowException(Exception(ExceptObject));
|
||||
end else
|
||||
@ -710,7 +727,7 @@ end;
|
||||
procedure TApplication.HandleMessage;
|
||||
begin
|
||||
InterfaceObject.HandleEvents; // process all events
|
||||
if not FTerminate then Idle;
|
||||
if not Terminated then Idle;
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
@ -848,6 +865,13 @@ begin
|
||||
|
||||
end;
|
||||
|
||||
{$IFDEF UseCustApp}
|
||||
function TApplication.GetConsoleApplication: boolean;
|
||||
begin
|
||||
Result:=false;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TApplication.SetHint(const AValue: string);
|
||||
begin
|
||||
if FHint=AValue then exit;
|
||||
@ -909,7 +933,8 @@ begin
|
||||
if AppNoExceptionMessages in FFlags then exit;
|
||||
Msg := E.Message;
|
||||
if (Msg <> '') and (Msg[length(Msg)] <> '.') then Msg := Msg + '.';
|
||||
if (not FTerminate) and (Self<>nil) then begin
|
||||
if (not {$IFDEF UseCustApp}Terminated{$ELSE}FTerminate{$ENDIF})
|
||||
and (Self<>nil) then begin
|
||||
MsgResult:=MessageBox(PChar(Msg),PChar(GetTitle),
|
||||
MB_OKCANCEL + MB_ICONERROR);
|
||||
if MsgResult<>mrOk then begin
|
||||
@ -918,7 +943,11 @@ begin
|
||||
Halt;
|
||||
end;
|
||||
end else
|
||||
{$IFDEF UseCustApp}
|
||||
inherited ShowException(E);
|
||||
{$ELSE}
|
||||
SysUtils.ShowException(ExceptObject, ExceptAddr);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
@ -927,7 +956,11 @@ end;
|
||||
{------------------------------------------------------------------------------}
|
||||
procedure TApplication.Terminate;
|
||||
begin
|
||||
{$IFDEF UseCustApp}
|
||||
inherited Terminate;
|
||||
{$ELSE}
|
||||
FTerminate := True;
|
||||
{$ENDIF}
|
||||
InterfaceObject.AppTerminate;
|
||||
end;
|
||||
|
||||
@ -1098,6 +1131,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.61 2003/08/12 21:35:11 mattias
|
||||
TApplication now descends from TCustomApplication
|
||||
|
||||
Revision 1.60 2003/08/09 16:30:33 mattias
|
||||
fixed LM_ShowModal for win32 intf from Karl
|
||||
|
||||
|
||||
@ -1388,7 +1388,7 @@ begin
|
||||
message, so it works there. The LCL is OS independent, and so it uses
|
||||
a better way: }
|
||||
InterfaceObject.HandleEvents; // process all events
|
||||
if Application.FTerminate then
|
||||
if Application.Terminated then
|
||||
ModalResult := mrCancel
|
||||
else if ModalResult <> 0 then begin
|
||||
CloseModal;
|
||||
@ -1423,6 +1423,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.109 2003/08/12 21:35:11 mattias
|
||||
TApplication now descends from TCustomApplication
|
||||
|
||||
Revision 1.108 2003/07/01 13:49:36 mattias
|
||||
clean up
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user