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

1350
components/fpcunit/guitestrunner.lrs
View File

File diff suppressed because it is too large Load Diff

125
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;
{$mode objfpc}{$H+}
@ -20,7 +36,7 @@ type
actCopy: TAction;
actCut: TAction;
ActionList1: TActionList;
BitBtn1: TBitBtn;
btnClose: TBitBtn;
btnRun: TBitBtn;
ComboBox1: TComboBox;
ImageList1: TImageList;
@ -30,12 +46,13 @@ type
MenuItem1: TMenuItem;
MenuItem2: TMenuItem;
MenuItem3: TMenuItem;
pbBar1: TPaintBox;
PopupMenu1: TPopupMenu;
PopupMenu2: TPopupMenu;
SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton;
XMLMemo: TMemo;
PaintBox1: TPaintBox;
pbBar: TPaintBox;
Panel4: TPanel;
Panel5: TPanel;
Splitter1: TSplitter;
@ -45,16 +62,13 @@ type
Panel3: TPanel;
tsTestTree: TTabSheet;
tsResultsXML: TTabSheet;
TreeView1: TTreeView;
procedure BitBtn1Click(Sender: TObject);
TestTree: TTreeView;
procedure BtnCloseClick(Sender: TObject);
procedure GUITestRunnerCreate(Sender: TObject);
procedure GUITestRunnerDestroy(Sender: TObject);
procedure MenuItem3Click(Sender: TObject);
procedure PaintBox1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
procedure TreeView1Click(Sender: TObject);
procedure XMLMemoChange(Sender: TObject);
procedure TestTreeSelectionChanged(Sender: TObject);
procedure pbBarPaint(Sender: TObject);
procedure actCopyExecute(Sender: TObject);
procedure actCutExecute(Sender: TObject);
procedure btnRunClick(Sender: TObject);
@ -62,7 +76,6 @@ type
{ private declarations }
suiteList: TStringList;
currentTestNode: TTreeNode;
EnabledTestsCount: Integer;
failureCounter: Integer;
errorCounter: Integer;
testsCounter: Integer;
@ -77,8 +90,7 @@ type
procedure AddError(ATest: TTest; AError: TTestFailure);
procedure StartTest(ATest: TTest);
procedure EndTest(ATest: TTest);
procedure DrawBar;
end;
end;
var
TestRunner: TGUITestRunner;
@ -87,39 +99,6 @@ implementation
{ 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);
begin
Clipboard.AsText := XMLMemo.Lines.Text;
@ -142,12 +121,11 @@ begin
ComboBox1.ItemIndex := 0;
end;
procedure TGUITestRunner.BitBtn1Click(Sender: TObject);
procedure TGUITestRunner.BtnCloseClick(Sender: TObject);
begin
Close;
end;
procedure TGUITestRunner.GUITestRunnerDestroy(Sender: TObject);
begin
suiteList.Free;
@ -158,16 +136,17 @@ begin
Clipboard.AsText := Memo1.Lines.Text;
end;
procedure TGUITestRunner.PaintBox1Click(Sender: TObject);
procedure TGUITestRunner.TestTreeSelectionChanged(Sender: TObject);
begin
if (Sender as TTreeView).Selected <> nil then
Memo1.Lines.Text := (Sender as TTreeview).Selected.Text
end;
procedure TGUITestRunner.PaintBox1Paint(Sender: TObject);
procedure TGUITestRunner.pbBarPaint(Sender: TObject);
var
msg: string;
begin
with PaintBox1 do
with (Sender as TPaintBox) do
begin
Canvas.Brush.Color := clGray;
Canvas.Rectangle(0, 0, Width, Height);
@ -176,8 +155,7 @@ begin
Canvas.Brush.Color := barColor;
if TestsCounter <> 0 then
begin
Canvas.Rectangle(0, 0, round((TestsCounter{- FailureCounter- ErrorCounter})/EnabledTestsCount*
Width), Height);
Canvas.Rectangle(0, 0, round(TestsCounter / GetTestRegistry.CountTestCases * Width), Height);
Canvas.Font.Color := clWhite;
msg := 'Runs: ' + IntToStr(TestsCounter);
if ErrorCounter <> 0 then
@ -194,14 +172,13 @@ var
testResult: TTestResult;
testSuite: TTest;
begin
TreeView1.items.Clear;
TestTree.items.Clear;
suiteList.Clear;
currentTestNode := nil;
if ComboBox1.ItemIndex = 0 then
testSuite := GetTestRegistry
else
testSuite := GetTestRegistry[ComboBox1.itemindex - 1];
enabledTestsCount := testSuite.CountTestCases;
failureCounter := 0;
errorCounter := 0;
testsCounter := 0;
@ -209,21 +186,23 @@ begin
try
testResult.AddListener(self);
testSuite.Run(testResult);
XMLMemo.lines.text:= TestResultAsXML(testResult);
XMLMemo.lines.text:= '<TestResults>' + system.sLineBreak +
TestResultAsXML(testResult) + system.sLineBreak + '</TestResults>';
finally
testResult.Free;
end;
PaintBox1.invalidate;
pbBar.invalidate;
pbBar1.invalidate;
end;
procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure);
var
node: TTreeNode;
begin
node := TreeView1.Items.AddChildObject(currentTestNode, 'Message: ' + AFailure.ExceptionMessage, AFailure);
node := TestTree.Items.AddChild(currentTestNode, 'Message: ' + AFailure.ExceptionMessage);
node.ImageIndex := 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.SelectedIndex := 4;
currentTestNode.ImageIndex := 3;
@ -232,7 +211,7 @@ begin
node.ImageIndex := 3;
node.SelectedIndex := 3;
Inc(failureCounter);
if BarColor <> clRed then
if errorCounter = 0 then
barColor := clFuchsia;
end;
@ -240,19 +219,19 @@ procedure TGUITestRunner.AddError(ATest: TTest; AError: TTestFailure);
var
node: TTreeNode;
begin
node := TreeView1.Items.AddChildObject(currentTestNode, 'Exception message: ' + AError.ExceptionMessage, AError);
node := TestTree.Items.AddChild(currentTestNode, 'Exception message: ' + AError.ExceptionMessage);
node.ImageIndex := 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.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.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.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.SelectedIndex := 11;
currentTestNode.ImageIndex := 2;
@ -274,30 +253,26 @@ begin
end
else
begin
if TreeView1.Items.Count = 0 then
if TestTree.Items.Count = 0 then
begin
parentNode := TreeView1.Items.AddFirst(nil, ATest.TestSuiteName);
parentNode := TestTree.Items.AddFirst(nil, ATest.TestSuiteName);
end
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);
end;
currentTestNode := TreeView1.Items.AddChildObject(parentNode, ATest.TestName, ATest);
currentTestNode := TestTree.Items.AddChild(parentNode, ATest.TestName);
Application.ProcessMessages;
end;
procedure TGUITestRunner.EndTest(ATest: TTest);
begin
Inc(testsCounter);
PaintBox1.invalidate;
pbBar.invalidate;
pbBar1.invalidate;
Application.ProcessMessages;
end;
procedure TGUITestRunner.DrawBar;
begin
end;
{ TGUITestRunner.IInterface }
function TGUITestRunner.QueryInterface(const IID: TGUID; out Obj): HResult; StdCall;

16
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.
It adds a new project type and a new unit type to the IDE.
New Project Type:
CGI Application - A Free Pascal program for CGI
using TCgiApplication for the main source (normally hidden,
just like the .lpr file for a normal Application).
New Unit Type:
CGI Module - A unit with a TCGIDatamodule.
This unit adds a new project type and a new unit type to the IDE.
New Project Type:
FPCUnit Application - A Free Pascal program for FPCUnit tests.
New Unit Type:
FPCUnit test - A unit with a unit test.