Browse Source

* introduce AbortRun

Michaël Van Canneyt 1 year ago
parent
commit
ecbebca07f
1 changed files with 10 additions and 1 deletions
  1. 10 1
      packages/fcl-base/src/custapp.pp

+ 10 - 1
packages/fcl-base/src/custapp.pp

@@ -47,6 +47,7 @@ Type
     FCaseSensitiveOptions : Boolean;
     FStopOnException : Boolean;
     FExceptionExitCode : Integer;
+    FRunAborted:Boolean;
     function GetEnvironmentVar(const VarName : String): String;
     function GetExeName: string;
     Function GetLocation : String;
@@ -59,6 +60,8 @@ Type
     procedure SetTitle(const AValue: string); Virtual;
     Function GetConsoleApplication : boolean; 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 GetParamCount: Integer;Virtual;
     Procedure DoLog(EventType : TEventType; const Msg : String);  virtual;
@@ -273,6 +276,11 @@ begin
   // Override in descendent classes.
 end;
 
+procedure TCustomApplication.AbortRun;
+begin
+  FRunAborted:=True;
+end;
+
 procedure TCustomApplication.DoLog(EventType: TEventType; const Msg: String);
 
 begin
@@ -353,7 +361,8 @@ begin
     except
       HandleException(Self);
     end;
-  Until FTerminated;
+    Writeln('Main needs to terminate: ',FTerminated,' or ',FRunAborted);
+  Until FTerminated or FRunAborted;
 end;
 
 procedure TCustomApplication.SetSingleInstanceClass(