mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 04:39:41 +01:00
130 lines
3.4 KiB
ObjectPascal
130 lines
3.4 KiB
ObjectPascal
{
|
|
Test with:
|
|
./parsertest --format=plain --suite=TTestParseFPCTestUnits
|
|
./parsertest --format=plain --suite=TestParse_ugenconstraints
|
|
./parsertest --format=plain --suite=TestParse_PT_Files
|
|
}
|
|
unit ParserTBase;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, CodeToolManager, ExprEval, CodeCache, LazFileUtils,
|
|
LazLogger, fpcunit, testregistry;
|
|
|
|
type
|
|
|
|
{ TTestParseFPCTestUnits }
|
|
|
|
TTestParseFPCTestUnits = class(TTestCase)
|
|
private
|
|
procedure TestParseFile(aFilename: string);
|
|
published
|
|
procedure TestParse_ugenconstraints;
|
|
procedure TestParse_PT_Files;
|
|
end;
|
|
|
|
var
|
|
BugsTestSuite: TTestSuite;
|
|
ParserTestSuite: TTestSuite;
|
|
|
|
procedure AddToBugsTestSuite(ATest: TTest);
|
|
procedure AddToParserTestSuite(ATestClass: TClass);
|
|
|
|
implementation
|
|
|
|
procedure AddToBugsTestSuite(ATest: TTest);
|
|
begin
|
|
BugsTestSuite.AddTest(ATest);
|
|
end;
|
|
|
|
procedure AddToParserTestSuite(ATestClass: TClass);
|
|
begin
|
|
ParserTestSuite.AddTestSuiteFromClass(ATestClass);
|
|
end;
|
|
|
|
{ TTestParseFPCTestUnits }
|
|
|
|
procedure TTestParseFPCTestUnits.TestParseFile(aFilename: string);
|
|
var
|
|
Code: TCodeBuffer;
|
|
Tool: TCodeTool;
|
|
Src: String;
|
|
ShouldFail: Boolean;
|
|
FailPos: SizeInt;
|
|
begin
|
|
Code:=CodeToolBoss.LoadFile(aFilename,true,false);
|
|
if Code=nil then begin
|
|
AssertEquals('unable to read file "'+aFilename+'"',true,false);
|
|
exit;
|
|
end;
|
|
ShouldFail:=false;
|
|
Src:=Code.Source;
|
|
FailPos:=0;
|
|
if copy(Src,1,6)='{fail:' then begin
|
|
ShouldFail:=true;
|
|
FailPos:=Pos('{fail}',Src);
|
|
if FailPos>0 then FailPos+=6;
|
|
end;
|
|
|
|
if CodeToolBoss.Explore(Code,Tool,true) then begin
|
|
if ShouldFail then
|
|
AssertEquals('parser skipped error file "'+aFilename+'"',true,false);
|
|
end else begin
|
|
if ShouldFail then begin
|
|
if FailPos>0 then
|
|
AssertEquals('wrong parser pos in file "'+aFilename+'"',Tool.CleanPosToStr(FailPos),Tool.CodeXYToStr(Tool.ErrorPosition));
|
|
end else begin
|
|
AssertEquals('unable to parse file "'+aFilename+'"',true,false);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTestParseFPCTestUnits.TestParse_ugenconstraints;
|
|
var
|
|
FPCDir: String;
|
|
Filename: String;
|
|
Code: TCodeBuffer;
|
|
Tool: TCodeTool;
|
|
begin
|
|
FPCDir:=TrimFilename(CodeToolBoss.GlobalValues.Variables[ExternalMacroStart+'FPCSrcDir']);
|
|
if not DirPathExists(FPCDir) then
|
|
raise Exception.Create('FPCDIR not found: '+FPCDir);
|
|
Filename:=AppendPathDelim(FPCDir)+'tests/test/ugenconstraints.pas';
|
|
//debugln(['TTestParseFPCTestUnits.TestParse_ugenconstraints ',Filename]);
|
|
Code:=CodeToolBoss.LoadFile(Filename,true,false);
|
|
if Code=nil then
|
|
raise Exception.Create('unable to load '+Filename);
|
|
if not CodeToolBoss.Explore(Code,Tool,true) then begin
|
|
debugln(['TTestParseFPCTestUnits.TestParse_ugenconstraints ',CodeToolBoss.ErrorMessage]);
|
|
end;
|
|
end;
|
|
|
|
procedure TTestParseFPCTestUnits.TestParse_PT_Files;
|
|
var
|
|
Info: TSearchRec;
|
|
Filename: TFilename;
|
|
Dir: String;
|
|
begin
|
|
Dir:=CleanAndExpandDirectory(GetCurrentDirUTF8);
|
|
if FindFirstUTF8(Dir+'pt_*.pas',faAnyFile,Info)=0 then begin
|
|
repeat
|
|
Filename:=Dir+Info.Name;
|
|
TestParseFile(Filename);
|
|
until FindNextUTF8(Info)<>0;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
GetTestRegistry.TestName := 'All tests';
|
|
BugsTestSuite := TTestSuite.Create('Bugs');
|
|
GetTestRegistry.AddTest(BugsTestSuite);
|
|
ParserTestSuite := TTestSuite.Create('Parser');
|
|
GetTestRegistry.AddTest(ParserTestSuite);
|
|
|
|
AddToParserTestSuite(TTestParseFPCTestUnits);
|
|
end.
|
|
|