paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 21:08:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* introduce AbortRun

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-05-12 13:54:29 +02:00
parent 1fa83a91ab
commit ecbebca07f
1 changed files with 10 additions and 1 deletions

11
packages/fcl-base/src/custapp.pp
View File

@ -47,6 +47,7 @@ Type
FCaseSensitiveOptions : Boolean; FCaseSensitiveOptions : Boolean;
FStopOnException : Boolean; FStopOnException : Boolean;
FExceptionExitCode : Integer; FExceptionExitCode : Integer;
FRunAborted:Boolean;
function GetEnvironmentVar(const VarName : String): String; function GetEnvironmentVar(const VarName : String): String;
function GetExeName: string; function GetExeName: string;
Function GetLocation : String; Function GetLocation : String;
@ -59,6 +60,8 @@ Type
procedure SetTitle(const AValue: string); Virtual; procedure SetTitle(const AValue: string); Virtual;
Function GetConsoleApplication : boolean; Virtual; Function GetConsoleApplication : boolean; Virtual;
Procedure DoRun; Virtual; Procedure DoRun; Virtual;
// Descendants can use this to stop the run loop without setting terminated.
procedure AbortRun; virtual;
Function GetParams(Index : Integer) : String;virtual; Function GetParams(Index : Integer) : String;virtual;
function GetParamCount: Integer;Virtual; function GetParamCount: Integer;Virtual;
Procedure DoLog(EventType : TEventType; const Msg : String); virtual; Procedure DoLog(EventType : TEventType; const Msg : String); virtual;
@ -273,6 +276,11 @@ begin
// Override in descendent classes. // Override in descendent classes.
end; end;
procedure TCustomApplication.AbortRun;
begin
FRunAborted:=True;
end;
procedure TCustomApplication.DoLog(EventType: TEventType; const Msg: String); procedure TCustomApplication.DoLog(EventType: TEventType; const Msg: String);
begin begin
@ -353,7 +361,8 @@ begin
except except
HandleException(Self); HandleException(Self);
end; end;
Until FTerminated; Writeln('Main needs to terminate: ',FTerminated,' or ',FRunAborted);
Until FTerminated or FRunAborted;
end; end;
procedure TCustomApplication.SetSingleInstanceClass( procedure TCustomApplication.SetSingleInstanceClass(