paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-01 12:23:42 +02:00
Code Issues Packages Projects Releases Wiki Activity
9da0d75b79
lazarus/components/fpcunit/ide/frmtestinsight.pas
Michaël Van Canneyt 876936e261 * remove debug statements
2023-12-27 10:39:18 +01:00

1354 lines
35 KiB
ObjectPascal
Raw Blame History

unit frmtestinsight;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LazFileUtils, LazUTF8, Forms, Controls,
Graphics, Dialogs, ExtCtrls, ComCtrls, ActnList, Menus, Clipbrd, StdCtrls,
LCLProc, AsyncProcess, IniFiles, fpJSON, testinsightprotocol,
testinsightserver, jsonparser, types, StrUtils, strtestcaseopts;
type
{ TTestInsightForm }
TTestInsightForm = class(TForm)
ActCloseForm: TAction;
ActCopyErrorMsg: TAction;
ActCheckCurrentSuite: TAction;
ActCheckAll: TAction;
ActCopyTextToClipboard: TAction;
aRefresh: TAction;
ActRunHighlightedTest: TAction;
ActUncheckAll: TAction;
ActUncheckCurrentSuite: TAction;
pTest: TAsyncProcess;
ilNodeStates: TImageList;
MMtestInsight: TMainMenu;
mDetails: TMemo;
MenuItem10: TMenuItem;
MenuItem11: TMenuItem;
MenuItem12: TMenuItem;
MenuItem13: TMenuItem;
MenuItem14: TMenuItem;
MenuItem15: TMenuItem;
MenuItem16: TMenuItem;
MenuItem17: TMenuItem;
MenuItem19: TMenuItem;
MenuItem2: TMenuItem;
MenuItemEdit: TMenuItem;
MenuItem3: TMenuItem;
MenuItemTestTree: TMenuItem;
MenuItemActions: TMenuItem;
miExpandNodes: TMenuItem;
miCollapseNodes: TMenuItem;
MenuItem4: TMenuItem;
MenuItem5: TMenuItem;
MenuItem6: TMenuItem;
MenuItem7: TMenuItem;
MenuItem8: TMenuItem;
MenuItem9: TMenuItem;
miRunTest: TMenuItem;
miShowfailureMsg: TMenuItem;
pbBar: TPaintBox;
pmResults: TPopupMenu;
actRunAll: TAction;
alTestInsight: TActionList;
sbTestInsight: TStatusBar;
TestTree: TTreeView;
TestTreeImageList: TImageList;
ILMenu: TImageList;
miRefresh: TMenuItem;
MenuItemCopyText: TMenuItem;
pmDetails: TPopupMenu;
Panel1: TPanel;
Panel2: TPanel;
ToolBar1: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
actNextError: TAction;
MenuItem20: TMenuItem;
actPrevError: TAction;
MenuItem21: TMenuItem;
MenuItem22: TMenuItem;
MenuItem23: TMenuItem;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
ToolButton5: TToolButton;
ToolButton6: TToolButton;
ToolButton7: TToolButton;
procedure actNextErrorUpdate(Sender: TObject);
procedure actPrevErrorUpdate(Sender: TObject);
procedure actRunAllUpdate(Sender: TObject);
procedure aRefreshExecute(Sender: TObject);
procedure aRefreshUpdate(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure pTestReadData(Sender: TObject);
procedure TestInsightFormCreate(Sender: TObject);
procedure TestInsightFormDestroy(Sender: TObject);
procedure ActCheckAllExecute(Sender: TObject);
procedure ActCheckCurrentSuiteExecute(Sender: TObject);
procedure ActCloseFormExecute(Sender: TObject);
procedure ActCopyTextToClipboardExecute(Sender: TObject);
procedure ActCopyTextToClipboardUpdate(Sender: TObject);
procedure ActRunHighlightedTestExecute(Sender: TObject);
procedure ActUncheckAllExecute(Sender: TObject);
procedure ActRunHighLightedTestUpdate(Sender: TObject);
procedure ActUncheckCurrentSuiteExecute(Sender: TObject);
procedure ActCopyErrorMsgExecute(Sender: TObject);
procedure ActCopyErrorMsgUpdate(Sender: TObject);
procedure actNextErrorExecute(Sender: TObject);
procedure actPrevErrorExecute(Sender: TObject);
procedure miCollapseNodesClick(Sender: TObject);
procedure miExpandNodesClick(Sender: TObject);
procedure RunAllExecute(Sender: TObject);
procedure TestTreeChange(Sender: TObject; Node: TTreeNode);
procedure TestTreeCreateNodeClass(Sender: TCustomTreeView; var NodeClass: TTreeNodeClass);
procedure TestTreeDblClick(Sender: TObject);
procedure TestTreeMouseDown(Sender: TObject; {%H-}Button: TMouseButton;
{%H-}Shift: TShiftState; X, Y: Integer);
procedure TestTreeSelectionChanged(Sender: TObject);
procedure pbBarPaint(Sender: TObject);
private
FConfStoreFile : String;
FTestProject : String;
FTestCount : Integer;
failureCounter: Integer;
errorCounter: Integer;
testsCounter: Integer;
skipsCounter: Integer;
barColor: TColor;
FTestSuite : TTestItem;
FSelectedTestSuite: TTestItem;
FFirstFailure: TTreeNode; // reference to first failed test
FServer : TTestInsightServer;
FTestsRunning : Boolean;
procedure AddSelected(N: TTreeNode; var Tests: TStringDynArray; var aLen: Integer);
// Callbacks for server
procedure DoClearTests(Sender: TObject);
procedure DoFinishedTests(Sender: TObject);
procedure DoGetSelectedTests(Sender: TObject; var Tests: TStringDynArray);
procedure DoSetTestResult(Sender: TObject; aResult: TTestInsightResultArray);
procedure DoGetOptions(Sender: TObject; aOptions: TTestInsightOptions);
procedure DoSetTestSuite(Sender: TObject; Tests: TTestItem);
procedure DoStartTests(Sender: TObject; aCount: Integer);
// Tree handling
function FindNode(aTest: String): TTreeNode;
function HaveErrors: Boolean;
function MakeTestPath(Node: TTreeNode): string;
procedure ResetNodeColors;
procedure PaintNodeError(aNode: TTreeNode);
procedure PaintNodeFailure(aNode: TTreeNode);
procedure PaintNodeIgnore(aNode: TTreeNode);
procedure PaintNodeNonFailed(aNode: TTreeNode);
procedure PaintNodeBusy(aNode: TTreeNode);
procedure EnableRunActions(AValue: boolean);
procedure ShowDetails(const Node: TTreeNode);
Protected
procedure ClearDetails;
procedure CreateTestRunConfigFile(aConfStoreFile: string; aSendNamesOnly: Boolean);
procedure ShowTestSuite;
procedure RestoreTree;
procedure SaveTree;
procedure BuildTree(rootNode: TTreeNode; aSuite: TTestItem);
Procedure SetFirstFailure(aNode: TTreeNode);
public
procedure AddFailure(aNode : TTreeNode; ATest: TTestItem);
procedure AddError(aNode : TTreeNode; ATest: TTestItem);
procedure StartTest(ATest: String);
procedure EndTest(aNode : TTreeNode; ATest: TTestItem);
procedure RunTest(ATest: TTestItem); virtual;
procedure NextError;
procedure PrevError;
procedure MaybeStartTestProject;
// test project handling. Needs to integrate with Lazarus IDE.
function ShowRefreshTestproject : Boolean; virtual;
function AutoFetchTests : Boolean; virtual;
function GetBaseURL: String; virtual;
function GetTestProject : String; virtual;
procedure RunTestProject(aExecutable : String; SendNamesOnly : Boolean); virtual;
function TestRunning : Boolean; virtual;
procedure ConfigureServer(aServer: TTestInsightServer); virtual;
function CreateServer(aOwner : TComponent) : TTestInsightServer; virtual;
procedure NavigateTo(const {%H-}aClass, {%H-}aMethod,{%H-}aUnit,{%H-}aLocationFile : String; {%H-}aLocationLine : Integer); virtual;
procedure DoneServer(aServer :TTestInsightServer); virtual;
procedure ShowMessage(aType : TInsightMessageType; Const Msg : String); virtual;
procedure HandleServerLog(Sender: TObject; const aType : TInsightMessageType; const aMessage: String); virtual;
Property Server : TTestInsightServer Read FServer;
public
end;
implementation
{$R *.lfm}
const
// TestTreeImageList indexes:
imgGreenBall = 0; //success result
imgRedBall = 2; // error result
imgPurpleBall = 3; //failure result
imgWarningSign = 4;
imgInfoSign = 11;
imgGrayBall = 12; //default
imgBlueBall = 13; //busy
const
SectionName_TestNodes = 'Tests';
type
TTreeNodeState=(tsUnChecked, tsChecked);
{ TMessageTreeNode }
TMessageTreeNode = class(TTreeNode)
private
FMessage: string;
public
property Message: string read FMessage write FMessage;
end;
function FirstLine(const s: string): string;
var
NewLinePos: integer;
begin
NewLinePos := pos(LineEnding, s);
if NewLinePos > 0 then
Result := copy(s, 1, NewLinePos-1)
else
Result := s;
end;
{ TTestInsightForm }
function TTestInsightForm.MakeTestPath(Node: TTreeNode): string;
begin
Result := Node.Text;
Node := Node.Parent;
If Node = Nil then Exit;
// We can now skip the unnecessary "All Tests" text
while Node.Parent <> nil do
begin
Result := Node.Text + '.' + Result;
Node := Node.Parent;
end;
end;
procedure TTestInsightForm.SaveTree;
function SkipNode(const Node: TTreeNode): boolean;
begin
Result := Node.Data = nil;
end;
var
i: integer;
NodePath : String;
begin
With TMemIniFile.Create(FConfStoreFile) do
Try
EraseSection(SectionName_TestNodes);
for i := 0 to TestTree.Items.Count-1 do
begin
if SkipNode(TestTree.Items[i]) then
continue;
NodePath:=MakeTestPath(TestTree.Items[i]);
WriteBool(SectionName_TestNodes,NodePath+ '.Checked',
TestTree.Items[i].StateIndex = Ord(tsChecked));
WriteBool(SectionName_TestNodes,NodePath + '.Expanded',
TestTree.Items[i].Expanded);
end;
UpdateFile;
Finally
Free;
end;
end;
procedure TTestInsightForm.RestoreTree;
Const
ImgIdx : Array[Boolean] of Integer = (Ord(tsUnChecked),Ord(tsChecked));
var
i: integer;
NodePath : String;
aIni : TMemIniFile;
begin
aIni:=TMemIniFile.Create(FConfStoreFile);
Try
if not aIni.SectionExists(SectionName_TestNodes) then
Exit;
for i := 0 to TestTree.Items.Count - 1 do
begin
NodePath:=MakeTestPath(TestTree.Items[i]);
With TestTree.Items[i] do
begin
Expanded:=aIni.ReadBool(SectionName_TestNodes, NodePath+ '.Expanded', Expanded);
StateIndex:=ImgIdx[aIni.ReadBool(SectionName_TestNodes,NodePath+ '.Checked',True)];
end;
end;
finally
aIni.Free;
end;
end;
procedure TTestInsightForm.ShowTestSuite;
begin
FTestCount:=FTestSuite.CountTestCases;
TestTree.BeginUpdate;
try
TestTree.Items.Clear;
BuildTree(TestTree.Items.AddObject(nil, rsAllTests, FTestSuite), FTestSuite);
RestoreTree;
// Select the first entry in the tree in order to immediately activate the
// Run All tests button:
if TestTree.Items.Count>0 then
begin
TestTree.Items.SelectOnlyThis(TestTree.Items[0]);
TestTree.Items[0].Expand(False);
end;
finally
TestTree.EndUpdate;
end;
end;
procedure TTestInsightForm.TestInsightFormCreate(Sender: TObject);
begin
barColor := clGreen;
TestTree.Items.Clear;
Caption:= sfrmGUITest;
actRunAll.Caption:= sactRunAction;
actRunAll.Hint:= sactRunActionH;
ActCloseForm.Caption:= sactCloseForm;
ActCloseForm.Hint:= sactCloseFormH;
ActCheckCurrentSuite.Caption:= sactCheckCurrentSuite;
ActUncheckCurrentSuite.Caption:= sactUncheckCurrentSuite;
ActCheckAll.Caption:= sactCheckAll;
ActUncheckAll.Caption:= sactUncheckAll;
ActRunHighlightedTest.Caption:= sactRunHighlightedTest;
ActRunHighlightedTest.Hint := sactRunHighlightedTestH;
MenuItemActions.Caption := smiActions;
MenuItemTestTree.Caption := smiTestTree;
MenuItemEdit.Caption := smiEdit;
miCollapseNodes.Caption := smiCollapseNodes;
miExpandNodes.Caption := smiExpandNodes;
actNextError.Caption := rsNextError;
actPrevError.Caption := rsPreviousError;
ActCopyErrorMsg.Caption := sactCopyMessageToClipboard;
ActCopyTextToClipboard.Caption := sactCopyAllToClipboard;
ActCopyTextToClipboard.Hint := sactCopyAllToClipboardH;
FServer:=CreateServer(Self);
FServer.OnClearTests:=@DoClearTests;
FServer.OnSetTestNames:=@DoSetTestSuite;
FServer.OnTestResult:=@DoSetTestResult;
FServer.OnGetSelectedTests:=@DoGetSelectedTests;
FServer.OnTestsStarted:=@DoStartTests;
FServer.OnTestsFinished:=@DoFinishedTests;
FServer.OnLog:=@HandleServerLog;
ConfigureServer(FServer);
FServer.StartServer;
MaybeStartTestProject;
end;
procedure TTestInsightForm.MaybeStartTestProject;
Var
ProjectPath : String;
begin
FTestProject:=GetTestProject;
if (FTestProject<>'') then
begin
sbTestInsight.SimpleText:=FTestProject;
ProjectPath:=ExtractFilePath(FTestProject);
FConfStoreFile := ProjectPath + 'TestInsightSettings.ini';
if AutoFetchTests then
RunTestProject(FTestProject,True); // Get all tests
end
else
sbTestInsight.SimpleText:=SNoTestProjectConfigured;
end;
procedure TTestInsightForm.ConfigureServer(aServer: TTestInsightServer);
begin
aServer.Port:=6789;
aServer.BasePath:='/tests';
end;
function TTestInsightForm.CreateServer(aOwner: TComponent): TTestInsightServer;
begin
Result:=TTestInsightServer.Create(aOwner)
end;
procedure TTestInsightForm.NavigateTo(const aClass,aMethod, aUnit, aLocationFile: String; aLocationLine: Integer);
begin
ShowMessage(imtInfo,SNavigationNotAvailable);
end;
procedure TTestInsightForm.DoneServer(aServer: TTestInsightServer);
begin
aServer.Free;
end;
procedure TTestInsightForm.ShowMessage(aType: TInsightMessageType; const Msg: String);
begin
Dialogs.ShowMessage(Msg);
end;
procedure TTestInsightForm.pTestReadData(Sender: TObject);
Type
TBuffer = Array[1..4096] of byte;
Var
Count : Integer;
Buf : TBuffer;
begin
Buf:=Default(TBuffer);
// We just clear the buffer
Count:=PTest.NumBytesAvailable;
While Count>0 do
Count:=Count-pTest.Output.Read(Buf,SizeOf(Buf));
end;
procedure TTestInsightForm.actRunAllUpdate(Sender: TObject);
begin
(Sender as TAction).Enabled:=Not Self.TestRunning;
end;
function TTestInsightForm.HaveErrors : Boolean;
begin
Result:=(failureCounter>0) or (errorCounter>0);
end;
procedure TTestInsightForm.actNextErrorUpdate(Sender: TObject);
begin
(Sender as TAction).Enabled:=HaveErrors;
end;
procedure TTestInsightForm.actPrevErrorUpdate(Sender: TObject);
begin
(Sender as TAction).Enabled:=HaveErrors;
end;
procedure TTestInsightForm.aRefreshExecute(Sender: TObject);
begin
MaybeStartTestProject;
end;
procedure TTestInsightForm.aRefreshUpdate(Sender: TObject);
begin
(Sender as TAction).Enabled:=ShowRefreshTestproject;
end;
procedure TTestInsightForm.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction:=caFree;
SaveTree;
end;
procedure TTestInsightForm.RunAllExecute(Sender: TObject);
begin
FFirstFailure := nil;
FSelectedTestSuite:=Nil;
RunTestProject(FTestProject,False);
end;
procedure TTestInsightForm.ActCloseFormExecute(Sender: TObject);
begin
Close;
end;
procedure TTestInsightForm.ActCopyTextToClipboardExecute(Sender: TObject);
begin
Clipboard.AsText := mDetails.Lines.Text
end;
procedure TTestInsightForm.ActCopyTextToClipboardUpdate(Sender: TObject);
begin
TAction(Sender).Enabled := (ActiveControl = mDetails) ;
end;
procedure TTestInsightForm.ActCheckAllExecute(Sender: TObject);
var
i: integer;
begin
for i := 0 to TestTree.Items.Count -1 do
TestTree.Items[i].StateIndex := ord(tsChecked);
end;
procedure TTestInsightForm.ActCheckCurrentSuiteExecute(Sender: TObject);
var
i: integer;
begin
if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
begin
TestTree.Selected.StateIndex := ord(tsChecked);
for i := 0 to TestTree.Selected.Count - 1 do
TestTree.Selected.Items[i].StateIndex := ord(tsChecked);
end;
end;
procedure TTestInsightForm.ActRunHighlightedTestExecute(Sender: TObject);
Var
N : TTreeNode;
begin
FFirstFailure := nil;
N:=TestTree.Selected;
if (N<>nil) then
begin
FSelectedTestSuite := TTestItem(N.Data);
if Assigned(FSelectedTestSuite) then
RunTest(FSelectedTestSuite);
end;
TestTree.MakeSelectionVisible;
end;
procedure TTestInsightForm.ActUncheckAllExecute(Sender: TObject);
var
i: integer;
begin
for i := 0 to TestTree.Items.Count -1 do
TestTree.Items[i].StateIndex := ord(tsUnChecked);
end;
procedure TTestInsightForm.ActRunHighLightedTestUpdate(Sender: TObject);
begin
(Sender as TAction).Enabled := ((TestTree.Selected <> nil)
and (TestTree.Selected.Data <> nil)) and not TestRunning;
end;
procedure TTestInsightForm.ActUncheckCurrentSuiteExecute(Sender: TObject);
var
i: integer;
begin
if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
begin
TestTree.Selected.StateIndex := ord(tsUnchecked);
for i := 0 to TestTree.Selected.Count - 1 do
TestTree.Selected.Items[i].StateIndex := ord(tsUnChecked);
end;
end;
procedure TTestInsightForm.TestInsightFormDestroy(Sender: TObject);
begin
DoneServer(FServer);
FreeAndNil(FTestSuite);
end;
procedure TTestInsightForm.miCollapseNodesClick(Sender: TObject);
begin
if not Assigned(TestTree.Selected) then
Exit;
TestTree.Selected.Collapse(True);
end;
procedure TTestInsightForm.miExpandNodesClick(Sender: TObject);
begin
if not Assigned(TestTree.Selected) then
Exit;
TestTree.Selected.Expand(True);
end;
procedure TTestInsightForm.TestTreeChange(Sender: TObject; Node: TTreeNode);
begin
if not Assigned(Node) then
Exit;
//mDetails.Lines.Text := TMessageTreeNode(Node).Message;
end;
procedure TTestInsightForm.TestTreeCreateNodeClass(Sender: TCustomTreeView;
var NodeClass: TTreeNodeClass);
begin
NodeClass := TMessageTreeNode;
end;
procedure TTestInsightForm.TestTreeDblClick(Sender: TObject);
function ExtractMethod(aPath : string; Out aClass,aMethod: String) : Boolean;
var
P : integer;
begin
Result:=False;
P:=RPos('.',aPath);
if P>0 then
begin
aMethod:=Copy(aPath,P+1,Length(aPath)-P);
aPath:=Copy(aPath,1,P-1);
P:=RPos('.',aPath);
if P>0 then
aClass:=Copy(aPath,P+1,Length(aPath)-P)
else
aClass:=aPath;
Result:=True;
end;
end;
var
Itm : TTestItem;
N : TTreeNode;
aClass,aMethod,aUnit : String;
aLocationFile : String;
aLocationLine : Integer;
begin
N:=TestTree.Selected;
Itm:=Nil;
While (Itm=Nil) and (N<>Nil) do
begin
if Assigned(N.Data) and (TObject(N.Data) is TTestItem) then
Itm:=TTestItem(N.Data)
else
N:=N.Parent;
end;
if Not assigned(itm) then
exit;
if Itm.TestResult=Nil then
begin
If not ExtractMethod(Itm.TestPath,aClass,aMethod) then
begin
ShowMessage(imtInfo,Format(rsCouldNotDete, [Itm.TestPath]));
exit;
end;
aUnit:='';
aLocationFile:='';
aLocationLine:=-1;
end
else
begin
With Itm.TestResult do
begin
aMethod:=TestMethodName;
aClass:=TestClassName;
aUnit:=TestUnitName;
aLocationFile:=FailureSourceUnitName;
aLocationLine:=FailureLineNumber;
end;
end;
NavigateTo(aClass, aMethod,aUnit,aLocationFile,aLocationLine);
end;
procedure TTestInsightForm.TestTreeMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure ChangeCheck(aNode: TTreeNode; aCheck: TTreeNodeState);
var
i: integer;
n: TTreeNode;
begin
if Assigned(aNode) then
begin
aNode.StateIndex := ord(aCheck);
if TTestItem(aNode.Data).IsTestSuite then
for i := 0 to aNode.Count - 1 do
begin
n := aNode.Items[i];
ChangeCheck(n, aCheck);
end;
end;
end;
var
ht: THitTests;
lNode: TTreeNode;
begin
ht := (Sender as TTreeview).GetHitTestInfoAt(X, Y);
if htOnStateIcon in ht then
begin
lNode := (Sender as TTreeview).GetNodeAt(X, Y);
case lNode.StateIndex of
0: ChangeCheck(lNode, tsChecked);
1: ChangeCheck(lNode, tsUnChecked);
end;
end;
end;
procedure TTestInsightForm.ClearDetails;
begin
mDetails.Lines.Clear;
end;
procedure TTestInsightForm.DoClearTests(Sender: TObject);
begin
DoSetTestSuite(Sender,TTestItem.Create(Nil,''));
end;
procedure TTestInsightForm.DoFinishedTests(Sender: TObject);
begin
FTestsRunning:=False;
pbBar.Refresh;
end;
procedure TTestInsightForm.AddSelected(N: TTreeNode;
var Tests: TStringDynArray; var aLen: Integer);
Var
I : integer;
begin
if Assigned(N.Data) and (TObject(N.Data) is TTestItem) then
if (N.StateIndex=Ord(tsChecked)) then
if TTestItem(N.Data).IsTestCase then
begin
Tests[aLen]:=TTestItem(N.Data).TestPath;
Inc(aLen);
end
else if TTestItem(N.Data).IsTestSuite then
For I:=0 to N.Count-1 do
AddSelected(N.items[i],Tests,aLen);
end;
procedure TTestInsightForm.DoGetSelectedTests(Sender: TObject; var Tests: TStringDynArray);
Var
aLen : integer;
begin
aLen:=0;
SetLength(Tests,TestTree.Items.Count);
if TestTree.Items.Count>0 then
AddSelected(TestTree.Items[0],Tests,aLen);
SetLength(Tests,aLen);
end;
procedure TTestInsightForm.DoSetTestResult(Sender: TObject; aResult: TTestInsightResultArray);
Var
I : Integer;
Res : TTestInsightResult;
Itm : TTestItem;
N : TTreeNode;
aName : string;
begin
For I:=0 to Length(aResult)-1 do
begin
Res:=aResult[i];
aName:=Res.TestName;
N:=FindNode(aName);
if N=Nil then
Res.Free
else
begin
Itm:=TTestItem(N.Data);
Itm.TestResult:=Res;
Case Res.TestResult of
rtFailed : AddFailure(N,Itm);
rtError : AddError(N,Itm);
rtWarning : AddFailure(N,Itm);
rtPassed : EndTest(N,Itm);
else
; //
end;
end;
end;
end;
procedure TTestInsightForm.DoGetOptions(Sender: TObject;
aOptions: TTestInsightOptions);
begin
// Normally only called during test if server is running
aOptions.ExecuteTests:=False;
if Assigned(FSelectedTestSuite) then
aOptions.TestSuite:=FSelectedTestSuite.TestPath
else
aOptions.TestSuite:=''
end;
procedure TTestInsightForm.DoSetTestSuite(Sender: TObject; Tests: TTestItem);
begin
FreeAndNil(FTestSuite);
FTestSuite:=Tests;
ShowTestSuite;
end;
procedure TTestInsightForm.DoStartTests(Sender: TObject; aCount: Integer);
begin
FTestsRunning:=true;
if aCount=-1 then
aCount:=FTestSuite.CountTestCases;
failureCounter:=0;
errorCounter:=0;
testsCounter:=0;
skipsCounter:=0;
pbBar.Refresh;
end;
procedure TTestInsightForm.HandleServerLog(Sender: TObject; const aType: TInsightMessageType; const aMessage: String);
begin
ShowMessage(atype,aMessage);
end;
procedure TTestInsightForm.ShowDetails(const Node: TTreeNode);
procedure AddMessages(const Node: TTreeNode);
begin
if (Node is TMessageTreeNode) and (TMessageTreeNode(Node).Message <> '') then
mDetails.Lines.Add(TMessageTreeNode(Node).Message)
else
mDetails.Lines.Add(Node.Text);
end;
var
CurrNode: TTreeNode;
begin
ClearDetails;
if TTestItem(Node.Data).IsTestCase then
begin
CurrNode := Node.GetFirstChild;
while CurrNode <> nil do
begin
AddMessages(CurrNode);
CurrNode := CurrNode.GetNextSibling;
end;
end
else if Assigned(Node.Parent) and Assigned(Node.Parent.Data) and TTestItem(Node.Parent.Data).IsTestCase then
AddMessages(Node);
end;
procedure TTestInsightForm.TestTreeSelectionChanged(Sender: TObject);
begin
if (Sender as TTreeView).Selected <> nil then
ShowDetails((Sender as TTreeView).Selected);
end;
procedure TTestInsightForm.ActCopyErrorMsgExecute(Sender: TObject);
begin
ClipBoard.AsText := (TestTree.Selected as TMessageTreeNode).Message;
end;
procedure TTestInsightForm.ActCopyErrorMsgUpdate(Sender: TObject);
begin
(Sender as TAction).Enabled := Assigned(TestTree.selected) and
(Copy(TestTree.Selected.Text, 1, 9) = 'Message: ');
end;
procedure TTestInsightForm.pbBarPaint(Sender: TObject);
var
msg: string;
alltests: integer;
OldStyle: TBrushStyle;
begin
with (Sender as TPaintBox) do
begin
Canvas.Lock;
if FTestsRunning then
Canvas.Brush.Color := clBlue
else
Canvas.Brush.Color := clSilver;
Canvas.Rectangle(0, 0, Width, Height);
Canvas.Font.Color := clWhite;
alltests := FTestCount;
if alltests - skipsCounter <> 0 then
begin
if FailureCounter + ErrorCounter = 0 then
barColor := clGreen;
Canvas.Brush.Color := barColor;
Canvas.Rectangle(0, 0, round(TestsCounter / (alltests - skipsCounter) * Width), Height);
msg := Format(rsRuns, [IntToStr(TestsCounter), IntToStr(alltests -
skipsCounter)]);
msg := Format(rsErrors, [msg, IntToStr(ErrorCounter)]);
msg := Format(rsFailures, [msg, IntToStr(FailureCounter)]);
OldStyle := Canvas.Brush.Style;
Canvas.Brush.Style := bsClear;
Canvas.Textout(10, 4, msg);
Canvas.Brush.Style := OldStyle;
end;
Canvas.UnLock;
end;
end;
procedure TTestInsightForm.actNextErrorExecute(Sender: TObject);
begin
NextError;
end;
procedure TTestInsightForm.actPrevErrorExecute(Sender: TObject);
begin
PrevError;
end;
procedure TTestInsightForm.BuildTree(rootNode: TTreeNode; aSuite: TTestItem);
var
node: TTreeNode;
i: integer;
Itm : TTestItem;
aName : TJSONStringType;
begin
rootNode.StateIndex := Ord(tsChecked);
for i := 0 to Length(ASuite.Tests) - 1 do
begin
itm:=ASuite.Tests[i];
aName:=Itm.TestName;
node := TestTree.Items.AddChildObject(rootNode, aName , itm);
if Itm.IsTestSuite then
BuildTree(Node, Itm);
node.ImageIndex := imgGrayBall;
node.SelectedIndex := imgGrayBall;
node.StateIndex := ord(tsChecked);
end;
ResetNodeColors;
end;
procedure TTestInsightForm.SetFirstFailure(aNode: TTreeNode);
begin
if FFirstFailure<>Nil then
exit;
FFirstFailure:=aNode;
TestTree.Items.SelectOnlyThis(FFirstFailure);
TestTree.MakeSelectionVisible;
end;
function TTestInsightForm.FindNode(aTest: String): TTreeNode;
var
i: integer;
tName : String;
begin
Result := nil;
for i := 0 to TestTree.Items.Count -1 do
begin
tName:=TTestItem(TestTree.Items[i].Data).TestPath;
if SameText(tName,aTest) then
Exit(TestTree.Items[i]);
end;
end;
procedure TTestInsightForm.ResetNodeColors;
var
i: integer;
begin
for i := 0 to TestTree.Items.Count - 1 do
begin
TestTree.Items[i].ImageIndex := imgGrayBall;
TestTree.Items[i].SelectedIndex := imgGrayBall;
end;
end;
procedure TTestInsightForm.PaintNodeError(aNode: TTreeNode);
begin
while Assigned(aNode) do
begin
aNode.ImageIndex := imgRedBall;
aNode.SelectedIndex := imgRedBall;
if aNode.AbsoluteIndex<>0 then begin
aNode.Expand(True);
end;
aNode := aNode.Parent;
end;
end;
procedure TTestInsightForm.PaintNodeFailure(aNode: TTreeNode);
begin
while Assigned(aNode) do
begin
if ((aNode.ImageIndex in [imgGreenBall, imgGrayBall, imgBlueBall]) or
(ANode.ImageIndex = -1)) then
begin
aNode.ImageIndex := imgPurpleBall;
aNode.SelectedIndex := imgPurpleBall;
if aNode.AbsoluteIndex<>0 then begin
aNode.Expand(true);
end;
end;
aNode := aNode.Parent;
end;
end;
procedure TTestInsightForm.PaintNodeIgnore(aNode: TTreeNode);
// Test results with Ignore
var
noFailedSibling: boolean;
i: integer;
begin
if Assigned(aNode) then
begin
if ((aNode.ImageIndex in [imgGrayBall, imgBlueBall]) or
(ANode.ImageIndex = -1)) then
begin
aNode.ImageIndex := imgGreenBall;
aNode.SelectedIndex := imgGreenBall;
end;
end;
if Assigned(aNode.Parent) then
if aNode.Index = aNode.Parent.Count -1 then
begin
aNode := aNode.Parent;
noFailedSibling := true;
for i := 0 to aNode.Count -2 do
begin
if aNode.Items[i].ImageIndex <> imgGreenBall then
noFailedSibling := false;;
end;
if (aNode.ImageIndex = imgBlueBall) and
noFailedSibling then
PaintNodeIgnore(aNode);
end;
end;
procedure TTestInsightForm.PaintNodeNonFailed(aNode: TTreeNode);
var
noFailedSibling: boolean;
i: integer;
begin
if Assigned(aNode) then
begin
if ((aNode.ImageIndex in [imgGrayBall, imgBlueBall]) or
(ANode.ImageIndex = -1)) then
begin
aNode.ImageIndex := imgGreenBall;
aNode.SelectedIndex := imgGreenBall;
end;
end;
if Assigned(aNode.Parent) then
if aNode.Index = aNode.Parent.Count -1 then // is aNode the last child
begin
aNode := aNode.Parent;
noFailedSibling := true;
for i := 0 to aNode.Count -2 do
begin
if aNode.Items[i].ImageIndex <> imgGreenBall then
noFailedSibling := false;
end;
if (aNode.ImageIndex = imgBlueBall) and
noFailedSibling then
PaintNodeNonFailed(aNode);
end;
end;
procedure TTestInsightForm.PaintNodeBusy(aNode: TTreeNode);
var
BusySibling: boolean;
i: integer;
begin
if Assigned(aNode) then
begin
aNode.ImageIndex := imgBlueBall;
aNode.SelectedIndex := imgBlueBall;
end;
if Assigned(aNode.Parent) then
begin
if aNode.Index = aNode.Parent.Count -1 then
begin
aNode := aNode.Parent;
BusySibling := true;
for i := 0 to aNode.Count -2 do
begin
if aNode.Items[i].ImageIndex <> imgGreenBall then
BusySibling := false;
end;
if (aNode.ImageIndex = imgBlueBall) and BusySibling then
PaintNodeBusy(aNode);
end;
end;
end;
procedure TTestInsightForm.EnableRunActions(AValue: boolean);
begin
ActRunHighlightedTest.Enabled := AValue;
actRunAll.Enabled := AValue;
end;
procedure TTestInsightForm.AddFailure(aNode : TTreeNode; ATest: TTestItem);
var
MNode: TMessageTreeNode;
aClass,aMessage : String;
begin
if not aTest.TestResult.TestIsIgnored then
begin
Inc(failureCounter);
if errorCounter = 0 then
barColor := clFuchsia;
end;
if Not Assigned(aNode) then
exit;
aMessage:=aTest.TestResult.TestExceptionMessage;
aClass:=aTest.TestResult.TestExceptionClass;
MNode := TestTree.Items.AddChild(aNode,
Format(rsMessage, [FirstLine(aMessage)]))
as TMessageTreeNode;
if not aTest.TestResult.TestIsIgnored then
begin
// Genuine failure
if not Assigned(FFirstFailure) then
SetFirstFailure(aNode);
MNode.Message := aMessage;
MNode.ImageIndex := imgWarningSign;
MNode.SelectedIndex := imgWarningSign;
MNode := TestTree.Items.AddChild(aNode,
Format(rsException, [aClass])) as TMessageTreeNode;
MNode.ImageIndex := imgWarningSign;
MNode.SelectedIndex := imgWarningSign;
if (aTest.TestResult.FailureLocationInfo<>'') then
begin
MNode := TestTree.Items.AddChild(aNode, 'at ' + aTest.TestResult.FailureLocationInfo) as TMessageTreeNode;
MNode.ImageIndex := imgWarningSign;
MNode.SelectedIndex := imgWarningSign;
PaintNodeFailure(aNode);
end;
end
else
begin
// Although reported as a failure, the test was set up
// to be ignored so it is actually a success of sorts
MNode.Message := aMessage;
MNode.ImageIndex := imgGreenBall;
MNode.SelectedIndex := imgGreenBall;
MNode := TestTree.Items.AddChild(aNode,
Format(rsException, [aClass])) as TMessageTreeNode;
MNode.ImageIndex := imgGreenBall;
MNode.SelectedIndex := imgGreenBall;
PaintNodeIgnore(aNode);
end;
ShowDetails(aNode);
end;
procedure TTestInsightForm.AddError(aNode : TTreeNode; ATest: TTestItem);
var
MNode: TMessageTreeNode;
aMessage, aClass,aLocation : String;
begin
Inc(errorCounter);
barColor := clRed;
aMessage:=aTest.TestResult.TestExceptionMessage;
aClass:=aTest.TestResult.TestExceptionClass;
aLocation:=aTest.TestResult.FailureLocationInfo;
if Not Assigned(aNode) then
exit;
if not Assigned(FFirstFailure) then
SetFirstFailure(aNode);
MNode := TestTree.Items.AddChild(aNode,
Format(rsExceptionMes, [FirstLine(aMessage)]))
as TMessageTreeNode;
MNode.Message := aMessage;
MNode.ImageIndex := imgWarningSign;
MNode.SelectedIndex := imgWarningSign;
MNode:=TestTree.Items.AddChild(aNode, Format(rsExceptionCla,[aClass])) as TMessageTreeNode;
MNode.ImageIndex := imgWarningSign;
MNode.SelectedIndex := imgWarningSign;
if (aLocation<>'') then
begin
MNode := TestTree.Items.AddChild(aNode, 'at ' + aLocation) as TMessageTreeNode;
MNode.ImageIndex := imgInfoSign;
MNode.SelectedIndex := imgInfoSign;
end;
PaintNodeError(aNode);
ShowDetails(aNode);
end;
procedure TTestInsightForm.StartTest(ATest: String);
var
Node: TTreeNode;
begin
TestTree.BeginUpdate;
try
Node := FindNode(ATest);
Node.DeleteChildren;
PaintNodeBusy(Node);
if Node.Level=1 then begin
Node.MakeVisible;
end;
if assigned(Node.Parent) and (Node.Parent.Level=1) then begin
Node.Parent.MakeVisible;
end;
Application.ProcessMessages;
finally
TestTree.EndUpdate;
end;
end;
procedure TTestInsightForm.EndTest(aNode : TTreeNode; ATest: TTestItem);
begin
TestTree.BeginUpdate;
try
Inc(testsCounter);
if not assigned(aNode) then
Exit;
PaintNodeNonFailed(aNode);
pbbar.Refresh;
Application.ProcessMessages;
finally
TestTree.EndUpdate;
end;
if aTest=Nil then;
end;
function TTestInsightForm.GetTestProject: String;
Var
ProjectPath : String;
begin
ProjectPath:=ExtractFilePath(ParamStr(0))+'testing'+PathDelim;
Result:= ProjectPath + 'clienttest'; // + extension ?
end;
procedure TTestInsightForm.RunTest(ATest: TTestItem);
begin
SaveTree;
ClearDetails;
barcolor := clGreen;
ResetNodeColors;
failureCounter := 0;
errorCounter := 0;
testsCounter := 0;
skipsCounter := 0;
EnableRunActions(false);
FSelectedTestSuite:=aTest;
RunTestProject(FTestProject,False);
end;
function TTestInsightForm.GetBaseURL: String;
begin
Result:=Format('http://localhost:%d%s',[FServer.Port,FServer.BasePath])
end;
procedure TTestInsightForm.CreateTestRunConfigFile(aConfStoreFile : string; aSendNamesOnly : Boolean);
Var
aIni:TmemIniFile;
begin
aIni:=TmemIniFile.Create(aConfStoreFile);
try
aIni.WriteString(SConfig,KeyBaseURL,GetBaseURL);
aIni.WriteBool(sConfig,keyExecuteTests,Not aSendNamesOnly);
if FSelectedTestSuite<>nil then
aIni.WriteString(SConfig,KeySuite,FSelectedTestSuite.TestPath)
else
aIni.DeleteKey(SConfig,KeySuite);
aIni.UpdateFile;
finally
aIni.Free;
end;
end;
procedure TTestInsightForm.RunTestProject(aExecutable: String; SendNamesOnly: Boolean);
begin
if TestRunning then
begin
ShowMessage(imtInfo,Format('The test project %s is still running',[aExecutable]));
Exit;
end;
if not FileExists(aExecutable) then
begin
ShowMessage(imtError,Format(SNoExecutableAvailable,[aExecutable]));
Exit;
end;
CreateTestRunConfigFile(FConfStoreFile,SendNamesOnly);
PTest.Executable:=aExecutable;
try
PTest.Execute;
except
On E : Exception do
ShowMessage(imtError,Format('Error %s while running test project %s: %s',[E.ClassName,aExecutable,E.Message]));
end;
FSelectedTestSuite:=Nil;
end;
function TTestInsightForm.TestRunning: Boolean;
begin
Result:=pTest.Running;
end;
procedure TTestInsightForm.NextError;
var
Node: TTreeNode;
begin
Node := TestTree.Selected;
while Assigned(Node) do
begin
Node := Node.GetNext;
if Assigned(Node)
and (Node.ImageIndex in [imgRedBall, imgPurpleBall])
and TTestItem(Node.Data).IsTestCase then
begin
TestTree.Selected := Node;
TestTree.MakeSelectionVisible;
Exit;
end;
end;
end;
procedure TTestInsightForm.PrevError;
var
Node: TTreeNode;
begin
Node := TestTree.Selected;
while Assigned(Node) do
begin
Node := Node.GetPrev;
if Assigned(Node) and (Node.ImageIndex in [imgRedBall, imgPurpleBall]) and
TTestItem(Node.Data).IsTestCase then
begin
TestTree.Selected := Node;
TestTree.MakeSelectionVisible;
Exit;
end;
end;
end;
function TTestInsightForm.ShowRefreshTestproject: Boolean;
begin
Result:=False;
end;
function TTestInsightForm.AutoFetchTests: Boolean;
begin
Result:=True;
end;
end.
Reference in New Issue View Git Blame Copy Permalink