mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-12 22:32:52 +02:00
481 lines
14 KiB
ObjectPascal
481 lines
14 KiB
ObjectPascal
{ Copyright (C) 2004 Vincent Snijders
|
|
|
|
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.
|
|
|
|
|
|
Abstract:
|
|
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.
|
|
|
|
See the README file for more information.
|
|
}
|
|
unit FPCUnitLazIDEIntf;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, LazIDEIntf, ProjectIntf, Controls, Forms,testcaseopts;
|
|
|
|
type
|
|
{ TFPCUnitApplicationDescriptor }
|
|
|
|
TFPCUnitApplicationDescriptor = class(TProjectDescriptor)
|
|
public
|
|
constructor Create; override;
|
|
function GetLocalizedName: string; override;
|
|
function GetLocalizedDescription: string; override;
|
|
function InitProject(AProject: TLazProject): TModalResult; override;
|
|
function CreateStartFiles(AProject: TLazProject): TModalResult; override;
|
|
end;
|
|
|
|
{ TFPCUnitConsoleApplicationDescriptor }
|
|
|
|
TFPCUnitConsoleApplicationDescriptor = class(TProjectDescriptor)
|
|
public
|
|
constructor Create; override;
|
|
function GetLocalizedName: string; override;
|
|
function GetLocalizedDescription: string; override;
|
|
function InitProject(AProject: TLazProject): TModalResult; override;
|
|
function CreateStartFiles(AProject: TLazProject): TModalResult; override;
|
|
end;
|
|
|
|
{ TFileDescPascalUnitFPCUnitTestCase }
|
|
|
|
TFileDescPascalUnitFPCUnitTestCase = class(TFileDescPascalUnit)
|
|
private
|
|
FTestCaseName: string;
|
|
FCreateSetup: boolean;
|
|
FCreateTearDown: boolean;
|
|
public
|
|
constructor Create; override;
|
|
function CreateSource(const Filename, SourceName,
|
|
ResourceName: string): string; override;
|
|
function GetInterfaceUsesSection: string; override;
|
|
function GetLocalizedName: string; override;
|
|
function GetLocalizedDescription: string; override;
|
|
function GetInterfaceSource(const Filename, SourceName,
|
|
ResourceName: string): string;override;
|
|
function GetImplementationSource(const Filename, SourceName,
|
|
ResourceName: string): string; override;
|
|
property TestCaseName: string read FTestCaseName write FTestCaseName;
|
|
property CreateSetup: boolean read FCreateSetup write FCreateSetup;
|
|
property CreateTeardown: boolean read FCreateTeardown write FCreateTeardown;
|
|
end;
|
|
|
|
var
|
|
ProjectDescriptorFPCUnitApplication: TFPCUnitApplicationDescriptor;
|
|
ProjectDescriptorFPCUnitConsoleApp: TFPCUnitConsoleApplicationDescriptor;
|
|
FileDescriptorFPCUnitTestCase: TFileDescPascalUnitFPCUnitTestCase;
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
procedure Register;
|
|
begin
|
|
FileDescriptorFPCUnitTestCase:=TFileDescPascalUnitFPCUnitTestCase.Create;
|
|
RegisterProjectFileDescriptor(FileDescriptorFPCUnitTestCase);
|
|
ProjectDescriptorFPCUnitConsoleApp := TFPCUnitConsoleApplicationDescriptor.Create;
|
|
RegisterProjectDescriptor(ProjectDescriptorFPCUnitConsoleApp);
|
|
ProjectDescriptorFPCUnitApplication:=TFPCUnitApplicationDescriptor.Create;
|
|
RegisterProjectDescriptor(ProjectDescriptorFPCUnitApplication);
|
|
end;
|
|
|
|
{ TFPCUnitApplicationDescriptor }
|
|
|
|
constructor TFPCUnitApplicationDescriptor.Create;
|
|
begin
|
|
inherited Create;
|
|
Name:='FPCUnit Application';
|
|
end;
|
|
|
|
function TFPCUnitApplicationDescriptor.GetLocalizedName: string;
|
|
begin
|
|
Result:='FPCUnit Test Application';
|
|
end;
|
|
|
|
function TFPCUnitApplicationDescriptor.GetLocalizedDescription: string;
|
|
var
|
|
le: string;
|
|
begin
|
|
le := System.LineEnding;
|
|
Result:='FPCUnit Test Application'+le+le
|
|
+'An application to run fpcunit test cases.'+le
|
|
+'The program file is '
|
|
+'automatically maintained by Lazarus.';
|
|
end;
|
|
|
|
function TFPCUnitApplicationDescriptor.InitProject(AProject: TLazProject): TModalResult;
|
|
var
|
|
le: string;
|
|
NewSource: String;
|
|
MainFile: TLazProjectFile;
|
|
begin
|
|
inherited InitProject(AProject);
|
|
|
|
MainFile:=AProject.CreateProjectFile('fpcunitproject1.lpr');
|
|
MainFile.IsPartOfProject:=true;
|
|
AProject.AddFile(MainFile,false);
|
|
AProject.MainFileID:=0;
|
|
|
|
// create program source
|
|
le:=LineEnding;
|
|
NewSource:='program FPCUnitProject1;'+le
|
|
+le
|
|
+'{$mode objfpc}{$H+}'+le
|
|
+le
|
|
+'uses'+le
|
|
+' Interfaces, Forms, GuiTestRunner;'+le
|
|
+le
|
|
+'begin'+le
|
|
+' Application.Initialize;'+le
|
|
+' Application.CreateForm(TGuiTestRunner, TestRunner);'+le
|
|
+' Application.Run;'+le
|
|
+'end.'+le
|
|
+le;
|
|
AProject.MainFile.SetSourceText(NewSource);
|
|
|
|
// add
|
|
AProject.AddPackageDependency('FCL');
|
|
AProject.AddPackageDependency('LCL');
|
|
AProject.AddPackageDependency('FPCUnitTestRunner');
|
|
|
|
// compiler options
|
|
AProject.LazCompilerOptions.UseLineInfoUnit:=true;
|
|
Result:=mrOK;
|
|
end;
|
|
|
|
function TFPCUnitApplicationDescriptor.CreateStartFiles(AProject: TLazProject): TModalResult;
|
|
begin
|
|
LazarusIDE.DoNewEditorFile(FileDescriptorFPCUnitTestCase,'','',
|
|
[nfIsPartOfProject,nfOpenInEditor,nfCreateDefaultSrc]);
|
|
Result:=mrOK;
|
|
end;
|
|
|
|
{ TFileDescPascalUnitFPCUnitTestCase }
|
|
|
|
constructor TFileDescPascalUnitFPCUnitTestCase.Create;
|
|
begin
|
|
inherited Create;
|
|
Name:='FPCUnit TestCase';
|
|
DefaultFilename:='testcase.pas';
|
|
DefaultSourceName:='TestCase1';
|
|
end;
|
|
|
|
function TFileDescPascalUnitFPCUnitTestCase.CreateSource(const Filename,
|
|
SourceName, ResourceName: string): string;
|
|
var
|
|
LE: string;
|
|
begin
|
|
CreateSetup := false;
|
|
CreateTeardown := false;
|
|
LE:=LineEnding;
|
|
with TTestCaseOptionsForm.Create(nil) do
|
|
try
|
|
edDefaultName.Text := 'T' + SourceName;
|
|
ShowModal;
|
|
if edDefaultName.Text <> '' then
|
|
TestCaseName := edDefaultName.Text
|
|
else
|
|
TestCaseName:= 'T' + SourceName;
|
|
if cbSetup.Checked then
|
|
CreateSetup := True
|
|
else
|
|
CreateSetup := False;
|
|
if cbTeardown.Checked then
|
|
CreateTeardown := True
|
|
else
|
|
CreateTeardown := False;
|
|
finally
|
|
Free;
|
|
end;
|
|
Result:=
|
|
'unit '+SourceName+';'+LE
|
|
+LE
|
|
+'{$mode objfpc}{$H+}'+LE
|
|
+LE
|
|
+'interface'+LE
|
|
+LE
|
|
+'uses'+LE
|
|
+' '+GetInterfaceUsesSection+';'+LE
|
|
+LE
|
|
+GetInterfaceSource(Filename,SourceName,ResourceName)
|
|
+'implementation'+LE
|
|
+LE
|
|
+GetImplementationSource(Filename,SourceName,ResourceName)
|
|
+'end.'+LE
|
|
+LE;
|
|
end;
|
|
|
|
function TFileDescPascalUnitFPCUnitTestCase.GetInterfaceUsesSection: string;
|
|
begin
|
|
Result:=inherited GetInterfaceUsesSection;
|
|
Result:=Result+', fpcunit, testutils, testregistry';
|
|
end;
|
|
|
|
function TFileDescPascalUnitFPCUnitTestCase.GetLocalizedName: string;
|
|
begin
|
|
Result:='FPCUnit Test Case';
|
|
end;
|
|
|
|
function TFileDescPascalUnitFPCUnitTestCase.GetLocalizedDescription: string;
|
|
begin
|
|
Result:='FPCUnit Test Case'#13
|
|
+'A unit containing a FPCUnit Test Case.';
|
|
end;
|
|
|
|
function TFileDescPascalUnitFPCUnitTestCase.GetInterfaceSource(const Filename,
|
|
SourceName, ResourceName: string): string;
|
|
var
|
|
le: string;
|
|
setupMethod: string;
|
|
teardownMethod: string;
|
|
protectedSection: string;
|
|
begin
|
|
le:=System.LineEnding;
|
|
if CreateSetup or CreateTeardown then
|
|
protectedSection := ' protected' + le;
|
|
if CreateSetup then
|
|
setupMethod := ' procedure SetUp; override;' + le;
|
|
if CreateTeardown then
|
|
teardownMethod := ' procedure TearDown; override;' + le;
|
|
Result := 'type' + le
|
|
+ le
|
|
+' '+TestCaseName+'= class(TTestCase)'+le
|
|
+ protectedSection
|
|
+ setupMethod
|
|
+ teardownMethod
|
|
+' published'+le
|
|
+' procedure TestHookUp;'+le
|
|
+' end;'+le+le;
|
|
end;
|
|
|
|
function TFileDescPascalUnitFPCUnitTestCase.GetImplementationSource(
|
|
const Filename, SourceName, ResourceName: string): string;
|
|
var
|
|
le: string;
|
|
setupMethod: string;
|
|
teardownMethod: string;
|
|
begin
|
|
le:=System.LineEnding;
|
|
if CreateSetup then
|
|
setupMethod := 'procedure '+TestCaseName+'.SetUp;'+le
|
|
+'begin'+le
|
|
+le
|
|
+'end;'+le;
|
|
if CreateTeardown then
|
|
teardownMethod := 'procedure '+TestCaseName+'.TearDown;'+le
|
|
+'begin'+le
|
|
+le
|
|
+'end;'+le;
|
|
Result:='procedure '+TestCaseName+'.TestHookUp;'+le
|
|
+'begin'+le
|
|
+' Fail(''Write your own test'');'+le
|
|
+'end;'+le
|
|
+le
|
|
+setupMethod
|
|
+le
|
|
+teardownMethod
|
|
+le
|
|
+'Initialization'+le
|
|
+le
|
|
+' RegisterTest('+TestCaseName+');'
|
|
+le;
|
|
end;
|
|
|
|
{ TFPCUnitConsoleApplicationDescriptor }
|
|
|
|
constructor TFPCUnitConsoleApplicationDescriptor.Create;
|
|
begin
|
|
inherited Create;
|
|
Name:='FPCUnit Console Application';
|
|
end;
|
|
|
|
function TFPCUnitConsoleApplicationDescriptor.GetLocalizedName: string;
|
|
begin
|
|
Result:='FPCUnit Console Test Application';
|
|
end;
|
|
|
|
function TFPCUnitConsoleApplicationDescriptor.GetLocalizedDescription: string;
|
|
var
|
|
le: string;
|
|
begin
|
|
le := System.LineEnding;
|
|
Result:='FPCUnit Console Test Application'+le+le
|
|
+'An application to run fpcunit test cases in console mode.'+le
|
|
+'The program file is '
|
|
+'automatically maintained by Lazarus.';
|
|
end;
|
|
|
|
function TFPCUnitConsoleApplicationDescriptor.InitProject(
|
|
AProject: TLazProject): TModalResult;
|
|
var
|
|
le: string;
|
|
NewSource: string;
|
|
MainFile: TLazProjectFile;
|
|
begin
|
|
inherited InitProject(AProject);
|
|
|
|
MainFile:=AProject.CreateProjectFile('fpcunitproject1.lpr');
|
|
MainFile.IsPartOfProject:=true;
|
|
AProject.AddFile(MainFile,false);
|
|
AProject.MainFileID:=0;
|
|
|
|
// create program source
|
|
le:=LineEnding;
|
|
NewSource:='program FPCUnitProject1;'+le
|
|
+le
|
|
+'{$mode objfpc}{$H+}'+le
|
|
+le
|
|
+'uses'+le
|
|
+' custapp, classes, sysutils, fpcunit, testreport, testregistry;'+le
|
|
+le
|
|
+'Const'+le
|
|
+' ShortOpts = ''alh'';'+le
|
|
+' Longopts : Array[1..5] of String = ('+le
|
|
+' ''all'',''list'',''format:'',''suite:'',''help'');'+le
|
|
+' Version = ''Version 0.1'';'+le
|
|
+le
|
|
+'Type'+le
|
|
+' TTestRunner = Class(TCustomApplication)'+le
|
|
+' private'+le
|
|
+' FXMLResultsWriter: TXMLResultsWriter;'+le
|
|
+' protected'+le
|
|
+' procedure DoRun ; Override;'+le
|
|
+' procedure doTestRun(aTest: TTest); virtual;'+le
|
|
+' public'+le
|
|
+' constructor Create(AOwner: TComponent); override;'+le
|
|
+' destructor Destroy; override;'+le
|
|
+' end;'+le
|
|
+le
|
|
+'constructor TTestRunner.Create(AOwner: TComponent);'+le
|
|
+'begin'+le
|
|
+' inherited Create(AOwner);'+le
|
|
+' FXMLResultsWriter := TXMLResultsWriter.Create;'+le
|
|
+'end;'+le
|
|
+le
|
|
+'destructor TTestRunner.Destroy;'+le
|
|
+'begin'+le
|
|
+' FXMLResultsWriter.Free;'+le
|
|
+'end;'+le
|
|
+le
|
|
+'procedure TTestRunner.doTestRun(aTest: TTest);'+le
|
|
+'var'+le
|
|
+' testResult: TTestResult;'+le
|
|
+'begin'+le
|
|
+' testResult := TTestResult.Create;'+le
|
|
+' try'+le
|
|
+' testResult.AddListener(FXMLResultsWriter);'+le
|
|
+' FXMLResultsWriter.WriteHeader;'+le
|
|
+' aTest.Run(testResult);'+le
|
|
+' FXMLResultsWriter.WriteResult(testResult);'+le
|
|
+' finally'+le
|
|
+' testResult.Free;'+le
|
|
+' end;'+le
|
|
+'end;'+le
|
|
+le
|
|
+'procedure TTestRunner.DoRun;'+le
|
|
+'var'+le
|
|
+' I : Integer;'+le
|
|
+' S : String;'+le
|
|
+'begin'+le
|
|
+' S:=CheckOptions(ShortOpts,LongOpts);'+le
|
|
+' If (S<>'''') then'+le
|
|
+' Writeln(S);'+le
|
|
+' if HasOption(''h'', ''help'') or (ParamCount = 0) then'+le
|
|
+' begin'+le
|
|
+' writeln(Title);'+le
|
|
+' writeln(Version);'+le
|
|
+' writeln(''Usage: '');'+le
|
|
+' writeln(''-l or --list to show a list of registered tests'');'+le
|
|
+' writeln(''default format is xml, add --format=latex to output the list as latex source'');'+le
|
|
+' writeln(''-a or --all to run all the tests and show the results in xml format'');'+le
|
|
+' writeln(''The results can be redirected to an xml file,'');'+le
|
|
+' writeln(''for example: ./testrunner --all > results.xml'');'+le
|
|
+' writeln(''use --suite=MyTestSuiteName to run only the tests in a single test suite class'');'+le
|
|
+' end;'+le
|
|
+' if HasOption(''l'', ''list'') then'+le
|
|
+' begin'+le
|
|
+' if HasOption(''format'') then'+le
|
|
+' begin'+le
|
|
+' if GetOptionValue(''format'') = ''latex'' then'+le
|
|
+' writeln(GetSuiteAsLatex(GetTestRegistry))'+le
|
|
+' else'+le
|
|
+' writeln(GetSuiteAsXML(GetTestRegistry));'+le
|
|
+' end'+le
|
|
+' else'+le
|
|
+' writeln(GetSuiteAsXML(GetTestRegistry));'+le
|
|
+' end;'+le
|
|
+' if HasOption(''a'', ''all'') then'+le
|
|
+' begin'+le
|
|
+' doTestRun(GetTestRegistry)'+le
|
|
+' end'+le
|
|
+' else'+le
|
|
+' if HasOption(''suite'') then'+le
|
|
+' begin'+le
|
|
+' S := '''';'+le
|
|
+' S:=GetOptionValue(''suite'');'+le
|
|
+' if S = '''' then'+le
|
|
+' for I := 0 to GetTestRegistry.Tests.count - 1 do'+le
|
|
+' writeln(GetTestRegistry[i].TestName)'+le
|
|
+' else'+le
|
|
+' for I := 0 to GetTestRegistry.Tests.count - 1 do'+le
|
|
+' if GetTestRegistry[i].TestName = S then'+le
|
|
+' begin'+le
|
|
+' doTestRun(GetTestRegistry[i]);'+le
|
|
+' end;'+le
|
|
+' end;'+le
|
|
+' Terminate;'+le
|
|
+'end;'+le
|
|
+le
|
|
+'Var'+le
|
|
+' App : TTestRunner;'+le
|
|
+le
|
|
+'begin'+le
|
|
+' App:=TTestRunner.Create(Nil);'+le
|
|
+' App.Initialize;'+le
|
|
+' App.Title := ''FPCUnit Console Test Case runner.'';'+le
|
|
+' App.Run;'+le
|
|
+' App.Free;'+le
|
|
+'end.'+le
|
|
+le;
|
|
AProject.MainFile.SetSourceText(NewSource);
|
|
|
|
// add
|
|
AProject.AddPackageDependency('FCL');
|
|
AProject.AddPackageDependency('FPCUnitTestRunner');
|
|
|
|
// compiler options
|
|
AProject.LazCompilerOptions.UseLineInfoUnit:=true;
|
|
Result:=mrOK;
|
|
end;
|
|
|
|
function TFPCUnitConsoleApplicationDescriptor.CreateStartFiles(
|
|
AProject: TLazProject): TModalResult;
|
|
begin
|
|
LazarusIDE.DoNewEditorFile(FileDescriptorFPCUnitTestCase,'','',
|
|
[nfIsPartOfProject,nfOpenInEditor,nfCreateDefaultSrc]);
|
|
Result:=mrOK;
|
|
end;
|
|
|
|
end.
|
|
|