paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-07 20:41:37 +02:00
Code Issues Packages Projects Releases Wiki Activity

fpcunit: Prevent enabling "run single test" while a test is running. Issue #40144.

Browse Source
This commit is contained in:
Juha 2023-03-05 09:50:12 +02:00
parent 68366d178c
commit 59babefde7
1 changed files with 5 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
components/fpcunit/guitestrunner.pas
View File

@ -152,6 +152,7 @@ type
testSuite: TTest;
FFirstFailure: TTreeNode; // reference to first failed test
FConfStore: TIniFile;
Running: boolean;
procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
procedure ClearDetails;
function FindNode(aTest: TTest): TTreeNode;
@ -459,8 +460,8 @@ end;
procedure TGUITestRunner.ActRunHighLightedTestUpdate(Sender: TObject);
begin
(Sender as TAction).Enabled := ((TestTree.Selected <> nil)
and (TestTree.Selected.Data <> nil));
(Sender as TAction).Enabled := (not Running) and
(TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil);
end;
procedure TGUITestRunner.ActUncheckCurrentSuiteExecute(Sender: TObject);
@ -1002,6 +1003,7 @@ var
xMethod: TOnBeforeOrAfterRunTestEvent;
I: integer;
begin
Running := true;
if Assigned(FGuiTestRunnerHandlers[gtrhtBeforeRunTest]) then
begin
for I := 0 to FGuiTestRunnerHandlers[gtrhtBeforeRunTest].Count-1 do
@ -1064,6 +1066,7 @@ begin
xMethod(Self);
end;
end;
Running := false;
end;
end;