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

clean up from Dean Zobec

Browse Source 
git-svn-id: trunk@6328 -
This commit is contained in:
vincents 2004-12-02 22:53:05 +00:00
parent 1e8b298e17
commit cd48c6349c
4 changed files with 785 additions and 802 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
components/fpcunit/guitestrunner.lfm
View File

@ -1,6 +1,6 @@
object GUITestRunner: TGUITestRunner object GUITestRunner: TGUITestRunner
Caption = 'fpcUnit - run unit tests' Caption = 'fpcUnit - run unit tests'
ClientHeight = 768 ClientHeight = 712
ClientWidth = 646 ClientWidth = 646
Icon.Data = { Icon.Data = {
C50100002F2A2058504D202A2F0A7374617469632063686172202A2062746E5F C50100002F2A2058504D202A2F0A7374617469632063686172202A2062746E5F
@ -21,11 +21,11 @@ object GUITestRunner: TGUITestRunner
} }
OnCreate = GUITestRunnerCreate OnCreate = GUITestRunnerCreate
OnDestroy = GUITestRunnerDestroy OnDestroy = GUITestRunnerDestroy
PixelsPerInch = 96 PixelsPerInch = 95
HorzScrollBar.Page = 647 HorzScrollBar.Page = 647
VertScrollBar.Page = 769 VertScrollBar.Page = 713
Left = 372 Left = 372
Height = 768 Height = 712
Top = 142 Top = 142
Width = 646 Width = 646
object Panel1: TPanel object Panel1: TPanel
@ -273,7 +273,7 @@ object GUITestRunner: TGUITestRunner
Top = 16 Top = 16
Width = 103 Width = 103
end end
object BitBtn1: TBitBtn object btnClose: TBitBtn
Caption = '&Exit' Caption = '&Exit'
Glyph.Data = { Glyph.Data = {
B42500002F2A2058504D202A2F0A7374617469632063686172202A2065786974 B42500002F2A2058504D202A2F0A7374617469632063686172202A2065786974
@ -579,11 +579,11 @@ object GUITestRunner: TGUITestRunner
2020202020202020202020202020202020202020202020202020202020202020 2020202020202020202020202020202020202020202020202020202020202020
2020202020202020202020202020202020202020227D3B0A 2020202020202020202020202020202020202020227D3B0A
} }
OnClick = BitBtn1Click OnClick = BtnCloseClick
TabOrder = 1 TabOrder = 1
Left = 536 Left = 536
Height = 48 Height = 48
Top = 16 Top = 15
Width = 96 Width = 96
end end
object Label1: TLabel object Label1: TLabel
@ -610,12 +610,12 @@ object GUITestRunner: TGUITestRunner
object Panel2: TPanel object Panel2: TPanel
Align = alClient Align = alClient
Caption = 'Panel2' Caption = 'Panel2'
ClientHeight = 686 ClientHeight = 630
ClientWidth = 646 ClientWidth = 646
FullRepaint = False FullRepaint = False
TabOrder = 1 TabOrder = 1
TabStop = True TabStop = True
Height = 686 Height = 630
Top = 82 Top = 82
Width = 646 Width = 646
object PageControl1: TPageControl object PageControl1: TPageControl
@ -624,42 +624,42 @@ object GUITestRunner: TGUITestRunner
TabIndex = 0 TabIndex = 0
TabOrder = 0 TabOrder = 0
Left = 1 Left = 1
Height = 684 Height = 628
Top = 1 Top = 1
Width = 644 Width = 644
object tsTestTree: TTabSheet object tsTestTree: TTabSheet
Caption = 'Testcase tree' Caption = 'Testcase tree'
ClientHeight = 658 ClientHeight = 606
ClientWidth = 636 ClientWidth = 644
Height = 658 Height = 606
Width = 636 Top = 22
object TreeView1: TTreeView Width = 644
object TestTree: TTreeView
Align = alTop Align = alTop
AutoExpand = True AutoExpand = True
BackgroundColor = clBtnFace BackgroundColor = clBtnFace
DefaultItemHeight = 16 DefaultItemHeight = 17
Images = ImageList1 Images = ImageList1
ParentCtl3D = False ParentCtl3D = False
ScrollBars = ssAutoBoth ScrollBars = ssAutoBoth
TabOrder = 0 TabOrder = 0
OnClick = TreeView1Click OnSelectionChanged = TestTreeSelectionChanged
Options = [tvoAutoExpand, tvoAutoItemHeight, tvoHideSelection, tvoKeepCollapsedNodes, tvoShowButtons, tvoShowLines, tvoShowRoot, tvoToolTips] Options = [tvoAutoExpand, tvoAutoItemHeight, tvoHideSelection, tvoKeepCollapsedNodes, tvoShowButtons, tvoShowLines, tvoShowRoot, tvoToolTips]
Height = 480 Height = 480
Top = 63 Top = 63
Width = 636 Width = 644
end end
object Panel4: TPanel object Panel4: TPanel
Align = alTop Align = alTop
ClientHeight = 63 ClientHeight = 63
ClientWidth = 636 ClientWidth = 644
FullRepaint = False FullRepaint = False
TabOrder = 1 TabOrder = 1
Height = 63 Height = 63
Width = 636 Width = 644
object PaintBox1: TPaintBox object pbBar: TPaintBox
ParentColor = True ParentColor = True
OnClick = PaintBox1Click OnPaint = pbBarPaint
OnPaint = PaintBox1Paint
Left = 22 Left = 22
Height = 32 Height = 32
Top = 15 Top = 15
@ -672,46 +672,47 @@ object GUITestRunner: TGUITestRunner
Height = 10 Height = 10
MinSize = 400 MinSize = 400
ParentColor = True ParentColor = True
Width = 636 Width = 644
Cursor = crVSplit Cursor = crVSplit
Height = 10 Height = 10
Top = 543 Top = 543
Width = 636 Width = 644
end end
object Memo1: TMemo object Memo1: TMemo
Align = alClient Align = alClient
PopupMenu = PopupMenu2 PopupMenu = PopupMenu2
TabOrder = 3 TabOrder = 3
Height = 105 Height = 53
Top = 553 Top = 553
Width = 636 Width = 644
end end
end end
object tsResultsXML: TTabSheet object tsResultsXML: TTabSheet
Caption = 'Results XML' Caption = 'Results XML'
ClientHeight = 658 ClientHeight = 606
ClientWidth = 636 ClientWidth = 644
Height = 658 Height = 606
Width = 636 Top = 22
Width = 644
object Panel3: TPanel object Panel3: TPanel
Align = alClient Align = alClient
Caption = 'Panel3' Caption = 'Panel3'
ClientHeight = 658 ClientHeight = 606
ClientWidth = 636 ClientWidth = 644
FullRepaint = False FullRepaint = False
TabOrder = 0 TabOrder = 0
TabStop = True TabStop = True
Height = 658 Height = 606
Width = 636 Width = 644
object Panel5: TPanel object Panel5: TPanel
Align = alTop Align = alTop
BorderWidth = 1 BorderWidth = 1
ClientHeight = 42 ClientHeight = 58
ClientWidth = 642 ClientWidth = 642
FullRepaint = False FullRepaint = False
TabOrder = 0 TabOrder = 0
Left = 1 Left = 1
Height = 42 Height = 58
Top = 1 Top = 1
Width = 642 Width = 642
object SpeedButton1: TSpeedButton object SpeedButton1: TSpeedButton
@ -834,7 +835,7 @@ object GUITestRunner: TGUITestRunner
Left = 16 Left = 16
Height = 30 Height = 30
Hint = 'Copy results to clipboard' Hint = 'Copy results to clipboard'
Top = 7 Top = 14
Width = 31 Width = 31
end end
object SpeedButton2: TSpeedButton object SpeedButton2: TSpeedButton
@ -895,18 +896,25 @@ object GUITestRunner: TGUITestRunner
Left = 54 Left = 54
Height = 30 Height = 30
Hint = 'Cut results to clipboard' Hint = 'Cut results to clipboard'
Top = 7 Top = 14
Width = 31 Width = 31
end end
object pbBar1: TPaintBox
ParentColor = True
OnPaint = pbBarPaint
Left = 110
Height = 31
Top = 14
Width = 512
end
end end
object XMLMemo: TMemo object XMLMemo: TMemo
Align = alClient Align = alClient
OnChange = XMLMemoChange
PopupMenu = PopupMenu1 PopupMenu = PopupMenu1
TabOrder = 1 TabOrder = 1
Left = 1 Left = 1
Height = 618 Height = 546
Top = 43 Top = 59
Width = 642 Width = 642
end end
end end
@ -914,8 +922,8 @@ object GUITestRunner: TGUITestRunner
end end
end end
object ImageList1: TImageList object ImageList1: TImageList
left = 20 left = 16
top = 464 top = 432
Bitmap = { Bitmap = {
6C690C00000010000000100000009D0E00002F2A2058504D202A2F0A73746174 6C690C00000010000000100000009D0E00002F2A2058504D202A2F0A73746174
69632063686172202A206C65646C69676874677265656E5F78706D5B5D203D20 69632063686172202A206C65646C69676874677265656E5F78706D5B5D203D20

1350
components/fpcunit/guitestrunner.lrs
View File

File diff suppressed because it is too large Load Diff

123
components/fpcunit/guitestrunner.pas
View File

@ -1,3 +1,19 @@
{ Copyright (C) 2004 Dean Zobec
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit GuiTestRunner; unit GuiTestRunner;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
@ -20,7 +36,7 @@ type
actCopy: TAction; actCopy: TAction;
actCut: TAction; actCut: TAction;
ActionList1: TActionList; ActionList1: TActionList;
BitBtn1: TBitBtn; btnClose: TBitBtn;
btnRun: TBitBtn; btnRun: TBitBtn;
ComboBox1: TComboBox; ComboBox1: TComboBox;
ImageList1: TImageList; ImageList1: TImageList;
@ -30,12 +46,13 @@ type
MenuItem1: TMenuItem; MenuItem1: TMenuItem;
MenuItem2: TMenuItem; MenuItem2: TMenuItem;
MenuItem3: TMenuItem; MenuItem3: TMenuItem;
pbBar1: TPaintBox;
PopupMenu1: TPopupMenu; PopupMenu1: TPopupMenu;
PopupMenu2: TPopupMenu; PopupMenu2: TPopupMenu;
SpeedButton1: TSpeedButton; SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton; SpeedButton2: TSpeedButton;
XMLMemo: TMemo; XMLMemo: TMemo;
PaintBox1: TPaintBox; pbBar: TPaintBox;
Panel4: TPanel; Panel4: TPanel;
Panel5: TPanel; Panel5: TPanel;
Splitter1: TSplitter; Splitter1: TSplitter;
@ -45,16 +62,13 @@ type
Panel3: TPanel; Panel3: TPanel;
tsTestTree: TTabSheet; tsTestTree: TTabSheet;
tsResultsXML: TTabSheet; tsResultsXML: TTabSheet;
TreeView1: TTreeView; TestTree: TTreeView;
procedure BitBtn1Click(Sender: TObject); procedure BtnCloseClick(Sender: TObject);
procedure GUITestRunnerCreate(Sender: TObject); procedure GUITestRunnerCreate(Sender: TObject);
procedure GUITestRunnerDestroy(Sender: TObject); procedure GUITestRunnerDestroy(Sender: TObject);
procedure MenuItem3Click(Sender: TObject); procedure MenuItem3Click(Sender: TObject);
procedure PaintBox1Click(Sender: TObject); procedure TestTreeSelectionChanged(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject); procedure pbBarPaint(Sender: TObject);
procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
procedure TreeView1Click(Sender: TObject);
procedure XMLMemoChange(Sender: TObject);
procedure actCopyExecute(Sender: TObject); procedure actCopyExecute(Sender: TObject);
procedure actCutExecute(Sender: TObject); procedure actCutExecute(Sender: TObject);
procedure btnRunClick(Sender: TObject); procedure btnRunClick(Sender: TObject);
@ -62,7 +76,6 @@ type
{ private declarations } { private declarations }
suiteList: TStringList; suiteList: TStringList;
currentTestNode: TTreeNode; currentTestNode: TTreeNode;
EnabledTestsCount: Integer;
failureCounter: Integer; failureCounter: Integer;
errorCounter: Integer; errorCounter: Integer;
testsCounter: Integer; testsCounter: Integer;
@ -77,7 +90,6 @@ type
procedure AddError(ATest: TTest; AError: TTestFailure); procedure AddError(ATest: TTest; AError: TTestFailure);
procedure StartTest(ATest: TTest); procedure StartTest(ATest: TTest);
procedure EndTest(ATest: TTest); procedure EndTest(ATest: TTest);
procedure DrawBar;
end; end;
var var
@ -87,39 +99,6 @@ implementation
{ TGUITestRunner } { TGUITestRunner }
procedure TGUITestRunner.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
end;
procedure TGUITestRunner.TreeView1Click(Sender: TObject);
var
Node: TTreeNode;
begin
if TreeView1.Selected <> nil then
begin
Memo1.Lines.Clear;
Node := TreeView1.Selected;
if (Node.Level = 2) then
if (TObject(Node.Data) is TTestFailure) then
begin
Memo1.Lines.Add('Exception Message: ' + TTestFailure(Node.Data).ExceptionMessage);
Memo1.Lines.Add('Exception Class Name: ' + TTestFailure(Node.Data).ExceptionClassName);
if TTestFailure(Node.Data).SourceUnitName <> '' then
begin
Memo1.Lines.Add('Unit Name: ' + TTestFailure(Node.Data).SourceUnitName);
Memo1.Lines.Add('Method Name: ' + TTestFailure(Node.Data).MethodName);
Memo1.Lines.Add('Line Number: ' + IntToStr(TTestFailure(Node.Data).LineNumber));
end;
end;
end;
end;
procedure TGUITestRunner.XMLMemoChange(Sender: TObject);
begin
end;
procedure TGUITestRunner.actCopyExecute(Sender: TObject); procedure TGUITestRunner.actCopyExecute(Sender: TObject);
begin begin
Clipboard.AsText := XMLMemo.Lines.Text; Clipboard.AsText := XMLMemo.Lines.Text;
@ -142,12 +121,11 @@ begin
ComboBox1.ItemIndex := 0; ComboBox1.ItemIndex := 0;
end; end;
procedure TGUITestRunner.BitBtn1Click(Sender: TObject); procedure TGUITestRunner.BtnCloseClick(Sender: TObject);
begin begin
Close; Close;
end; end;
procedure TGUITestRunner.GUITestRunnerDestroy(Sender: TObject); procedure TGUITestRunner.GUITestRunnerDestroy(Sender: TObject);
begin begin
suiteList.Free; suiteList.Free;
@ -158,16 +136,17 @@ begin
Clipboard.AsText := Memo1.Lines.Text; Clipboard.AsText := Memo1.Lines.Text;
end; end;
procedure TGUITestRunner.PaintBox1Click(Sender: TObject); procedure TGUITestRunner.TestTreeSelectionChanged(Sender: TObject);
begin begin
if (Sender as TTreeView).Selected <> nil then
Memo1.Lines.Text := (Sender as TTreeview).Selected.Text
end; end;
procedure TGUITestRunner.PaintBox1Paint(Sender: TObject); procedure TGUITestRunner.pbBarPaint(Sender: TObject);
var var
msg: string; msg: string;
begin begin
with PaintBox1 do with (Sender as TPaintBox) do
begin begin
Canvas.Brush.Color := clGray; Canvas.Brush.Color := clGray;
Canvas.Rectangle(0, 0, Width, Height); Canvas.Rectangle(0, 0, Width, Height);
@ -176,8 +155,7 @@ begin
Canvas.Brush.Color := barColor; Canvas.Brush.Color := barColor;
if TestsCounter <> 0 then if TestsCounter <> 0 then
begin begin
Canvas.Rectangle(0, 0, round((TestsCounter{- FailureCounter- ErrorCounter})/EnabledTestsCount* Canvas.Rectangle(0, 0, round(TestsCounter / GetTestRegistry.CountTestCases * Width), Height);
Width), Height);
Canvas.Font.Color := clWhite; Canvas.Font.Color := clWhite;
msg := 'Runs: ' + IntToStr(TestsCounter); msg := 'Runs: ' + IntToStr(TestsCounter);
if ErrorCounter <> 0 then if ErrorCounter <> 0 then
@ -194,14 +172,13 @@ var
testResult: TTestResult; testResult: TTestResult;
testSuite: TTest; testSuite: TTest;
begin begin
TreeView1.items.Clear; TestTree.items.Clear;
suiteList.Clear; suiteList.Clear;
currentTestNode := nil; currentTestNode := nil;
if ComboBox1.ItemIndex = 0 then if ComboBox1.ItemIndex = 0 then
testSuite := GetTestRegistry testSuite := GetTestRegistry
else else
testSuite := GetTestRegistry[ComboBox1.itemindex - 1]; testSuite := GetTestRegistry[ComboBox1.itemindex - 1];
enabledTestsCount := testSuite.CountTestCases;
failureCounter := 0; failureCounter := 0;
errorCounter := 0; errorCounter := 0;
testsCounter := 0; testsCounter := 0;
@ -209,21 +186,23 @@ begin
try try
testResult.AddListener(self); testResult.AddListener(self);
testSuite.Run(testResult); testSuite.Run(testResult);
XMLMemo.lines.text:= TestResultAsXML(testResult); XMLMemo.lines.text:= '<TestResults>' + system.sLineBreak +
TestResultAsXML(testResult) + system.sLineBreak + '</TestResults>';
finally finally
testResult.Free; testResult.Free;
end; end;
PaintBox1.invalidate; pbBar.invalidate;
pbBar1.invalidate;
end; end;
procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure); procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure);
var var
node: TTreeNode; node: TTreeNode;
begin begin
node := TreeView1.Items.AddChildObject(currentTestNode, 'Message: ' + AFailure.ExceptionMessage, AFailure); node := TestTree.Items.AddChild(currentTestNode, 'Message: ' + AFailure.ExceptionMessage);
node.ImageIndex := 4; node.ImageIndex := 4;
node.SelectedIndex := 4; node.SelectedIndex := 4;
node := TreeView1.Items.AddChildObject(currentTestNode, 'Exception: ' + AFailure.ExceptionClassName, AFailure); node := TestTree.Items.AddChild(currentTestNode, 'Exception: ' + AFailure.ExceptionClassName);
node.ImageIndex := 4; node.ImageIndex := 4;
node.SelectedIndex := 4; node.SelectedIndex := 4;
currentTestNode.ImageIndex := 3; currentTestNode.ImageIndex := 3;
@ -232,7 +211,7 @@ begin
node.ImageIndex := 3; node.ImageIndex := 3;
node.SelectedIndex := 3; node.SelectedIndex := 3;
Inc(failureCounter); Inc(failureCounter);
if BarColor <> clRed then if errorCounter = 0 then
barColor := clFuchsia; barColor := clFuchsia;
end; end;
@ -240,19 +219,19 @@ procedure TGUITestRunner.AddError(ATest: TTest; AError: TTestFailure);
var var
node: TTreeNode; node: TTreeNode;
begin begin
node := TreeView1.Items.AddChildObject(currentTestNode, 'Exception message: ' + AError.ExceptionMessage, AError); node := TestTree.Items.AddChild(currentTestNode, 'Exception message: ' + AError.ExceptionMessage);
node.ImageIndex := 4; node.ImageIndex := 4;
node.SelectedIndex := 4; node.SelectedIndex := 4;
node := TreeView1.Items.AddChildObject(currentTestNode, 'Exception class: ' + AError.ExceptionClassName, AError); node := TestTree.Items.AddChild(currentTestNode, 'Exception class: ' + AError.ExceptionClassName);
node.ImageIndex := 4; node.ImageIndex := 4;
node.SelectedIndex := 4; node.SelectedIndex := 4;
node := TreeView1.Items.AddChildObject(currentTestNode, 'Unit name: ' + AError.SourceUnitName, AError); node := TestTree.Items.AddChild(currentTestNode, 'Unit name: ' + AError.SourceUnitName);
node.ImageIndex := 11; node.ImageIndex := 11;
node.SelectedIndex := 11; node.SelectedIndex := 11;
node := TreeView1.Items.AddChildObject(currentTestNode, 'Method name: ' + AError.MethodName, AError); node := TestTree.Items.AddChild(currentTestNode, 'Method name: ' + AError.MethodName);
node.ImageIndex := 11; node.ImageIndex := 11;
node.SelectedIndex := 11; node.SelectedIndex := 11;
node := TreeView1.Items.AddChildObject(currentTestNode, 'Line number: ' + IntToStr(AError.LineNumber), AError); node := TestTree.Items.AddChild(currentTestNode, 'Line number: ' + IntToStr(AError.LineNumber));
node.ImageIndex := 11; node.ImageIndex := 11;
node.SelectedIndex := 11; node.SelectedIndex := 11;
currentTestNode.ImageIndex := 2; currentTestNode.ImageIndex := 2;
@ -274,30 +253,26 @@ begin
end end
else else
begin begin
if TreeView1.Items.Count = 0 then if TestTree.Items.Count = 0 then
begin begin
parentNode := TreeView1.Items.AddFirst(nil, ATest.TestSuiteName); parentNode := TestTree.Items.AddFirst(nil, ATest.TestSuiteName);
end end
else else
parentNode := TreeView1.Items.Add(TTreeNode(suiteList.Objects[SuiteList.Count - 1]), ATest.TestSuiteName); parentNode := TestTree.Items.Add(TTreeNode(suiteList.Objects[SuiteList.Count - 1]), ATest.TestSuiteName);
suiteList.AddObject(ATest.TestSuiteName, parentNode); suiteList.AddObject(ATest.TestSuiteName, parentNode);
end; end;
currentTestNode := TreeView1.Items.AddChildObject(parentNode, ATest.TestName, ATest); currentTestNode := TestTree.Items.AddChild(parentNode, ATest.TestName);
Application.ProcessMessages; Application.ProcessMessages;
end; end;
procedure TGUITestRunner.EndTest(ATest: TTest); procedure TGUITestRunner.EndTest(ATest: TTest);
begin begin
Inc(testsCounter); Inc(testsCounter);
PaintBox1.invalidate; pbBar.invalidate;
pbBar1.invalidate;
Application.ProcessMessages; Application.ProcessMessages;
end; end;
procedure TGUITestRunner.DrawBar;
begin
end;
{ TGUITestRunner.IInterface } { TGUITestRunner.IInterface }
function TGUITestRunner.QueryInterface(const IID: TGUID; out Obj): HResult; StdCall; function TGUITestRunner.QueryInterface(const IID: TGUID; out Obj): HResult; StdCall;

14
components/fpcunit/ide/README.txt
View File

@ -1,16 +1,14 @@
Package CGILazIDE Package fpcunit
This package is a designtime package for the Lazarus IDE. This package is a designtime package for the Lazarus IDE.
It adds a new project type and a new unit type to the IDE. It adds a new project type and a new unit type to the IDE.
New Project Type: This unit adds a new project type and a new unit type to the IDE.
CGI Application - A Free Pascal program for CGI New Project Type:
using TCgiApplication for the main source (normally hidden, FPCUnit Application - A Free Pascal program for FPCUnit tests.
just like the .lpr file for a normal Application).
New Unit Type:
CGI Module - A unit with a TCGIDatamodule.
New Unit Type:
FPCUnit test - A unit with a unit test.