mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-06 23:26:32 +02:00
user can select tests in treeview from Dean
git-svn-id: trunk@6723 -
This commit is contained in:
vincents
parent
e8e13b3fb6
commit
7f1e74218c
@ -20,7 +20,6 @@ object GUITestRunner: TGUITestRunner
|
||||
2020202020227D3B0A
|
||||
}
|
||||
OnCreate = GUITestRunnerCreate
|
||||
OnDestroy = GUITestRunnerDestroy
|
||||
OnShow = GUITestRunnerShow
|
||||
PixelsPerInch = 95
|
||||
HorzScrollBar.Page = 645
|
||||
@ -31,7 +30,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Width = 646
|
||||
object Panel1: TPanel
|
||||
Align = alTop
|
||||
BorderSpacing.OnChange = nil
|
||||
ClientHeight = 82
|
||||
ClientWidth = 646
|
||||
FullRepaint = False
|
||||
@ -40,7 +38,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Height = 82
|
||||
Width = 646
|
||||
object Label1: TLabel
|
||||
BorderSpacing.OnChange = nil
|
||||
Caption = 'Selected Test Suite:'
|
||||
ParentColor = True
|
||||
Left = 160
|
||||
@ -48,8 +45,17 @@ object GUITestRunner: TGUITestRunner
|
||||
Top = 16
|
||||
Width = 176
|
||||
end
|
||||
object lblSelectedTest: TLabel
|
||||
Caption = 'All Tests'
|
||||
Color = clNone
|
||||
Font.CharSet = ANSI_CHARSET
|
||||
Font.Color = clBlue
|
||||
Left = 161
|
||||
Height = 23
|
||||
Top = 40
|
||||
Width = 343
|
||||
end
|
||||
object btnRun: TBitBtn
|
||||
BorderSpacing.OnChange = nil
|
||||
Caption = '&Run'
|
||||
Glyph.Data = {
|
||||
191C00002F2A2058504D202A2F0A7374617469632063686172202A2062746E5F
|
||||
@ -286,7 +292,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Width = 103
|
||||
end
|
||||
object btnClose: TBitBtn
|
||||
BorderSpacing.OnChange = nil
|
||||
Caption = '&Exit'
|
||||
Glyph.Data = {
|
||||
B42500002F2A2058504D202A2F0A7374617469632063686172202A2065786974
|
||||
@ -599,23 +604,9 @@ object GUITestRunner: TGUITestRunner
|
||||
Top = 15
|
||||
Width = 96
|
||||
end
|
||||
object ComboBox1: TComboBox
|
||||
BorderSpacing.OnChange = nil
|
||||
Items.Strings = (
|
||||
'All'
|
||||
)
|
||||
MaxLength = 0
|
||||
Style = csDropDownList
|
||||
Text = 'All'
|
||||
Left = 160
|
||||
Height = 21
|
||||
Top = 32
|
||||
Width = 276
|
||||
end
|
||||
end
|
||||
object Panel2: TPanel
|
||||
Align = alClient
|
||||
BorderSpacing.OnChange = nil
|
||||
Caption = 'Panel2'
|
||||
ClientHeight = 630
|
||||
ClientWidth = 646
|
||||
@ -628,7 +619,6 @@ object GUITestRunner: TGUITestRunner
|
||||
object PageControl1: TPageControl
|
||||
ActivePage = tsTestTree
|
||||
Align = alClient
|
||||
BorderSpacing.OnChange = nil
|
||||
TabIndex = 0
|
||||
TabOrder = 0
|
||||
Left = 1
|
||||
@ -645,7 +635,6 @@ object GUITestRunner: TGUITestRunner
|
||||
object TestTree: TTreeView
|
||||
Align = alTop
|
||||
AutoExpand = True
|
||||
BorderSpacing.OnChange = nil
|
||||
BackgroundColor = clBtnFace
|
||||
ChangeDelay = 1
|
||||
DefaultItemHeight = 16
|
||||
@ -661,7 +650,6 @@ object GUITestRunner: TGUITestRunner
|
||||
end
|
||||
object Panel4: TPanel
|
||||
Align = alTop
|
||||
BorderSpacing.OnChange = nil
|
||||
ClientHeight = 63
|
||||
ClientWidth = 644
|
||||
FullRepaint = False
|
||||
@ -669,7 +657,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Height = 63
|
||||
Width = 644
|
||||
object pbBar: TPaintBox
|
||||
BorderSpacing.OnChange = nil
|
||||
ParentColor = True
|
||||
OnPaint = pbBarPaint
|
||||
Left = 22
|
||||
@ -692,7 +679,6 @@ object GUITestRunner: TGUITestRunner
|
||||
end
|
||||
object Memo1: TMemo
|
||||
Align = alClient
|
||||
BorderSpacing.OnChange = nil
|
||||
PopupMenu = PopupMenu2
|
||||
TabOrder = 2
|
||||
Height = 53
|
||||
@ -709,7 +695,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Width = 644
|
||||
object Panel3: TPanel
|
||||
Align = alClient
|
||||
BorderSpacing.OnChange = nil
|
||||
Caption = 'Panel3'
|
||||
ClientHeight = 606
|
||||
ClientWidth = 644
|
||||
@ -720,7 +705,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Width = 644
|
||||
object Panel5: TPanel
|
||||
Align = alTop
|
||||
BorderSpacing.OnChange = nil
|
||||
BorderWidth = 1
|
||||
ClientHeight = 58
|
||||
ClientWidth = 642
|
||||
@ -732,7 +716,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Width = 642
|
||||
object SpeedButton1: TSpeedButton
|
||||
Action = actCopy
|
||||
BorderSpacing.OnChange = nil
|
||||
Flat = True
|
||||
Glyph.Data = {
|
||||
880D00002F2A2058504D202A2F0A7374617469632063686172202A2065646974
|
||||
@ -856,7 +839,6 @@ object GUITestRunner: TGUITestRunner
|
||||
end
|
||||
object SpeedButton2: TSpeedButton
|
||||
Action = actCut
|
||||
BorderSpacing.OnChange = nil
|
||||
Flat = True
|
||||
Glyph.Data = {
|
||||
CC0500002F2A2058504D202A2F0A7374617469632063686172202A2065646974
|
||||
@ -917,7 +899,6 @@ object GUITestRunner: TGUITestRunner
|
||||
Width = 31
|
||||
end
|
||||
object pbBar1: TPaintBox
|
||||
BorderSpacing.OnChange = nil
|
||||
ParentColor = True
|
||||
OnPaint = pbBarPaint
|
||||
Left = 110
|
||||
@ -928,7 +909,6 @@ object GUITestRunner: TGUITestRunner
|
||||
end
|
||||
object XMLMemo: TMemo
|
||||
Align = alClient
|
||||
BorderSpacing.OnChange = nil
|
||||
PopupMenu = PopupMenu1
|
||||
TabOrder = 1
|
||||
Left = 1
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -40,10 +40,10 @@ type
|
||||
ActionList1: TActionList;
|
||||
btnClose: TBitBtn;
|
||||
btnRun: TBitBtn;
|
||||
ComboBox1: TComboBox;
|
||||
ImageList1: TImageList;
|
||||
ImageList2: TImageList;
|
||||
Label1: TLabel;
|
||||
lblSelectedTest: TLabel;
|
||||
Memo1: TMemo;
|
||||
MenuItem1: TMenuItem;
|
||||
MenuItem2: TMenuItem;
|
||||
@ -67,7 +67,6 @@ type
|
||||
TestTree: TTreeView;
|
||||
procedure BtnCloseClick(Sender: TObject);
|
||||
procedure GUITestRunnerCreate(Sender: TObject);
|
||||
procedure GUITestRunnerDestroy(Sender: TObject);
|
||||
procedure GUITestRunnerShow(Sender: TObject);
|
||||
procedure MenuItem3Click(Sender: TObject);
|
||||
procedure TestTreeSelectionChanged(Sender: TObject);
|
||||
@ -76,14 +75,14 @@ type
|
||||
procedure actCutExecute(Sender: TObject);
|
||||
procedure btnRunClick(Sender: TObject);
|
||||
private
|
||||
{ private declarations }
|
||||
suiteList: TStringList;
|
||||
currentTestNode: TTreeNode;
|
||||
failureCounter: Integer;
|
||||
errorCounter: Integer;
|
||||
testsCounter: Integer;
|
||||
barColor: TColor;
|
||||
testSuite: TTest;
|
||||
procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
|
||||
function FindNode(aTest: TTest): TTreeNode;
|
||||
procedure ResetNodeColors;
|
||||
protected
|
||||
{ IInterface }
|
||||
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
|
||||
@ -118,11 +117,9 @@ procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
suiteList := TStringList.Create;
|
||||
barColor := clGray;
|
||||
for i := 0 to GetTestRegistry.Tests.Count - 1 do
|
||||
ComboBox1.Items.Add(GetTestRegistry.Test[i].TestName);
|
||||
ComboBox1.ItemIndex := 0;
|
||||
TestTree.Items.Clear;
|
||||
BuildTree(TestTree.Items.AddObject(nil, 'All Tests', GetTestRegistry), GetTestRegistry);
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.BtnCloseClick(Sender: TObject);
|
||||
@ -130,11 +127,6 @@ begin
|
||||
Close;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.GUITestRunnerDestroy(Sender: TObject);
|
||||
begin
|
||||
suiteList.Free;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.GUITestRunnerShow(Sender: TObject);
|
||||
begin
|
||||
if (ParamStr(1) = '--now') or (ParamStr(1) = '-n') then
|
||||
@ -147,9 +139,14 @@ begin
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.TestTreeSelectionChanged(Sender: TObject);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
if (Sender as TTreeView).Selected <> nil then
|
||||
Memo1.Lines.Text := (Sender as TTreeview).Selected.Text
|
||||
begin
|
||||
Memo1.Lines.Text := (Sender as TTreeview).Selected.Text;
|
||||
lblSelectedTest.Caption := (Sender as TTreeview).Selected.Text;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.pbBarPaint(Sender: TObject);
|
||||
@ -186,13 +183,11 @@ var
|
||||
testResult: TTestResult;
|
||||
begin
|
||||
barcolor := clGray;
|
||||
TestTree.items.Clear;
|
||||
suiteList.Clear;
|
||||
currentTestNode := nil;
|
||||
if ComboBox1.ItemIndex = 0 then
|
||||
testSuite := GetTestRegistry
|
||||
ResetNodeColors;
|
||||
if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
|
||||
testSuite := TTest(TestTree.Selected.Data)
|
||||
else
|
||||
testSuite := GetTestRegistry[ComboBox1.itemindex - 1];
|
||||
testSuite := GetTestRegistry;
|
||||
failureCounter := 0;
|
||||
errorCounter := 0;
|
||||
testsCounter := 0;
|
||||
@ -209,21 +204,65 @@ begin
|
||||
pbBar1.invalidate;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
procedure TGUITestRunner.BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
|
||||
var
|
||||
node: TTreeNode;
|
||||
i: integer;
|
||||
begin
|
||||
node := TestTree.Items.AddChild(currentTestNode, 'Message: ' + AFailure.ExceptionMessage);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TestTree.Items.AddChild(currentTestNode, 'Exception: ' + AFailure.ExceptionClassName);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
currentTestNode.ImageIndex := 3;
|
||||
currentTestNode.SelectedIndex := 3;
|
||||
node := TTreeNode(suiteList.Objects[suiteList.IndexOf(ATest.TestSuiteName)]);
|
||||
node.ImageIndex := 3;
|
||||
node.SelectedIndex := 3;
|
||||
for i := 0 to ASuite.Tests.Count - 1 do
|
||||
begin
|
||||
node := TestTree.Items.AddChildObject(rootNode, ASuite.Test[i].TestName, ASuite.Test[i]);
|
||||
if ASuite.Test[i] is TTestSuite then
|
||||
BuildTree(Node, ASuite.Test[i] as TTestSuite);
|
||||
node.ImageIndex := -1;
|
||||
node.SelectedIndex := -1;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TGUITestRunner.FindNode(aTest: TTest): TTreeNode;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := nil;
|
||||
for i := 0 to TestTree.Items.Count -1 do
|
||||
if (TTest(TestTree.Items[i].data) = aTest) then
|
||||
begin
|
||||
Result := TestTree.Items[i];
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.ResetNodeColors;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i := 0 to TestTree.Items.Count - 1 do
|
||||
begin
|
||||
TestTree.Items[i].ImageIndex := -1;
|
||||
TestTree.Items[i].SelectedIndex := -1;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
var
|
||||
FailureNode, node: TTreeNode;
|
||||
begin
|
||||
FailureNode := FindNode(ATest);
|
||||
if Assigned(FailureNode) then
|
||||
begin
|
||||
FailureNode.DeleteChildren;
|
||||
node := TestTree.Items.AddChild(FailureNode, 'Message: ' + AFailure.ExceptionMessage);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TestTree.Items.AddChild(FailureNode, 'Exception: ' + AFailure.ExceptionClassName);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
FailureNode.ImageIndex := 3;
|
||||
FailureNode.SelectedIndex := 3;
|
||||
node := FailureNode.Parent;
|
||||
node.ImageIndex := 3;
|
||||
node.SelectedIndex := 3;
|
||||
end;
|
||||
Inc(failureCounter);
|
||||
if errorCounter = 0 then
|
||||
barColor := clFuchsia;
|
||||
@ -231,51 +270,52 @@ end;
|
||||
|
||||
procedure TGUITestRunner.AddError(ATest: TTest; AError: TTestFailure);
|
||||
var
|
||||
node: TTreeNode;
|
||||
ErrorNode, node: TTreeNode;
|
||||
begin
|
||||
node := TestTree.Items.AddChild(currentTestNode, 'Exception message: ' + AError.ExceptionMessage);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TestTree.Items.AddChild(currentTestNode, 'Exception class: ' + AError.ExceptionClassName);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TestTree.Items.AddChild(currentTestNode, 'Unit name: ' + AError.SourceUnitName);
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
node := TestTree.Items.AddChild(currentTestNode, 'Method name: ' + AError.MethodName);
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
node := TestTree.Items.AddChild(currentTestNode, 'Line number: ' + IntToStr(AError.LineNumber));
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
currentTestNode.ImageIndex := 2;
|
||||
currentTestNode.SelectedIndex := 2;
|
||||
node := TTreeNode(suiteList.Objects[suiteList.IndexOf(ATest.TestSuiteName)]);
|
||||
node.ImageIndex := 2;
|
||||
node.SelectedIndex := 2;
|
||||
ErrorNode := FindNode(ATest);
|
||||
if Assigned(ErrorNode) then
|
||||
begin
|
||||
ErrorNode.DeleteChildren;
|
||||
node := TestTree.Items.AddChild(ErrorNode, 'Exception message: ' + AError.ExceptionMessage);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TestTree.Items.AddChild(ErrorNode, 'Exception class: ' + AError.ExceptionClassName);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TestTree.Items.AddChild(ErrorNode, 'Unit name: ' + AError.SourceUnitName);
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
node := TestTree.Items.AddChild(ErrorNode, 'Method name: ' + AError.MethodName);
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
node := TestTree.Items.AddChild(ErrorNode, 'Line number: ' + IntToStr(AError.LineNumber));
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
ErrorNode.ImageIndex := 2;
|
||||
ErrorNode.SelectedIndex := 2;
|
||||
node := ErrorNode.Parent;
|
||||
node.ImageIndex := 2;
|
||||
node.SelectedIndex := 2;
|
||||
end;
|
||||
Inc(errorCounter);
|
||||
barColor := clRed;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.StartTest(ATest: TTest);
|
||||
var
|
||||
parentNode: TTreeNode;
|
||||
Node: TTreeNode;
|
||||
begin
|
||||
if suiteList.IndexOf(ATest.TestSuiteName) <> -1 then
|
||||
Node := FindNode(ATest);
|
||||
if Assigned(Node) then
|
||||
begin
|
||||
parentNode := TTreeNode(suiteList.Objects[suiteList.IndexOf(ATest.TestSuiteName)]);
|
||||
end
|
||||
else
|
||||
Node.ImageIndex := 0;
|
||||
Node.SelectedIndex := 0;
|
||||
if Assigned(Node.Parent) and (Node.Parent.ImageIndex = -1) then
|
||||
begin
|
||||
if TestTree.Items.Count = 0 then
|
||||
begin
|
||||
parentNode := TestTree.Items.AddFirst(nil, ATest.TestSuiteName);
|
||||
end
|
||||
else
|
||||
parentNode := TestTree.Items.Add(TTreeNode(suiteList.Objects[SuiteList.Count - 1]), ATest.TestSuiteName);
|
||||
suiteList.AddObject(ATest.TestSuiteName, parentNode);
|
||||
Node.Parent.ImageIndex := 0;
|
||||
Node.Parent.SelectedIndex := 0;
|
||||
end;
|
||||
currentTestNode := TestTree.Items.AddChild(parentNode, ATest.TestName);
|
||||
end;
|
||||
Application.ProcessMessages;
|
||||
end;
|
||||
|
||||
@ -284,6 +324,25 @@ begin
|
||||
Inc(testsCounter);
|
||||
pbBar.invalidate;
|
||||
pbBar1.invalidate;
|
||||
if TestsCounter = GetTestRegistry.CountTestCases then
|
||||
begin
|
||||
if (ErrorCounter = 0) and (FailureCounter = 0) then
|
||||
begin
|
||||
TestTree.items[0].ImageIndex := 0;
|
||||
TestTree.items[0].SelectedIndex := 0;
|
||||
end
|
||||
else
|
||||
if (ErrorCounter > 0) then
|
||||
begin
|
||||
TestTree.items[0].ImageIndex := 2;
|
||||
TestTree.items[0].SelectedIndex := 2;
|
||||
end
|
||||
else
|
||||
begin
|
||||
TestTree.items[0].ImageIndex := 3;
|
||||
TestTree.items[0].SelectedIndex := 3;
|
||||
end;
|
||||
end;
|
||||
Application.ProcessMessages;
|
||||
end;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user