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

user can select tests in treeview from Dean

Browse Source 
git-svn-id: trunk@6723 -
This commit is contained in:
vincents 2005-02-03 11:57:13 +00:00
parent e8e13b3fb6
commit 7f1e74218c
3 changed files with 1293 additions and 1254 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
components/fpcunit/guitestrunner.lfm
View File

@ -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

2314
components/fpcunit/guitestrunner.lrs
View File

File diff suppressed because it is too large Load Diff

157
components/fpcunit/guitestrunner.pas
View File

@ -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);
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(currentTestNode, 'Exception: ' + AFailure.ExceptionClassName);
node := TestTree.Items.AddChild(FailureNode, 'Exception: ' + AFailure.ExceptionClassName);
node.ImageIndex := 4;
node.SelectedIndex := 4;
currentTestNode.ImageIndex := 3;
currentTestNode.SelectedIndex := 3;
node := TTreeNode(suiteList.Objects[suiteList.IndexOf(ATest.TestSuiteName)]);
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);
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(currentTestNode, 'Exception class: ' + AError.ExceptionClassName);
node := TestTree.Items.AddChild(ErrorNode, 'Exception class: ' + AError.ExceptionClassName);
node.ImageIndex := 4;
node.SelectedIndex := 4;
node := TestTree.Items.AddChild(currentTestNode, 'Unit name: ' + AError.SourceUnitName);
node := TestTree.Items.AddChild(ErrorNode, 'Unit name: ' + AError.SourceUnitName);
node.ImageIndex := 11;
node.SelectedIndex := 11;
node := TestTree.Items.AddChild(currentTestNode, 'Method name: ' + AError.MethodName);
node := TestTree.Items.AddChild(ErrorNode, 'Method name: ' + AError.MethodName);
node.ImageIndex := 11;
node.SelectedIndex := 11;
node := TestTree.Items.AddChild(currentTestNode, 'Line number: ' + IntToStr(AError.LineNumber));
node := TestTree.Items.AddChild(ErrorNode, '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)]);
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;
end;
currentTestNode := TestTree.Items.AddChild(parentNode, ATest.TestName);
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;