paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-25 14:39:11 +02:00
Code Issues Packages Projects Releases Wiki Activity

codetools: test CheckLFM child component

Browse Source
This commit is contained in:
mattias 2023-01-17 22:41:17 +01:00
parent 029f775a85
commit 09c3e47a45
1 changed files with 102 additions and 43 deletions

145
components/codetools/tests/testlfmtrees.pas
View File

@ -23,6 +23,10 @@ type
protected
procedure SetUp; override;
procedure TearDown; override;
function AddControls(const aFilename: string = 'controls.pas'): TCodeBuffer;
function AddFormUnit(const Fields: array of string;
const aFormClass: string = 'TForm';
const aFilename: string = 'unit1.pas'): TCodeBuffer;
function AddSource(aFilename, aSource: string): TCodeBuffer;
public
constructor Create; override;
@ -42,6 +46,7 @@ type
TTestLFMTrees = class(TCustomTestLFMTrees)
published
procedure LFMEmptyForm;
procedure LFMButton1;
end;
implementation
@ -61,35 +66,6 @@ end;
procedure TCustomTestLFMTrees.SetUp;
begin
inherited SetUp;
FControlsCode:=AddSource('controls.pas',LinesToStr([
'unit Controls;',
'{$mode objfpc}{$H+}',
'interface',
'uses Classes;',
'type',
' TCaption = type string;',
' TAction = class(TComponent)',
' published',
' property OnExecute: TNotifyEvent;',
' end;',
'',
' TControl = class(TComponent)',
' published',
' property Caption: TCaption;',
' property Left: integer;',
' property Top: integer;',
' property OnClick: TNotifyEvent;',
' end;',
' TFormStyle = (fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop, fsSplash, fsSystemStayOnTop);',
' TForm = class(TControl)',
' published',
' property FormStyle: TFormStyle;',
' end;',
'end.',
'implementation',
'end.'
]));
end;
procedure TCustomTestLFMTrees.TearDown;
@ -108,9 +84,75 @@ begin
inherited TearDown;
end;
function TCustomTestLFMTrees.AddControls(const aFilename: string): TCodeBuffer;
begin
FControlsCode:=AddSource(aFilename,LinesToStr([
'unit Controls;',
'{$mode objfpc}{$H+}',
'interface',
'uses Classes;',
'type',
' TCaption = type string;',
' TAction = class(TComponent)',
' published',
' property OnExecute: TNotifyEvent;',
' end;',
'',
' TControl = class(TComponent)',
' published',
' property Caption: TCaption;',
' property Left: integer;',
' property Top: integer;',
//' property Width: integer;',
//' property Height: integer;',
' property OnClick: TNotifyEvent;',
' end;',
'',
' TButton = class(TControl)',
' published',
' property Default: Boolean;',
' end;',
'',
' TFormStyle = (fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop, fsSplash, fsSystemStayOnTop);',
' TForm = class(TControl)',
' published',
' property FormStyle: TFormStyle;',
' end;',
'end.',
'implementation',
'end.'
]));
Result:=FControlsCode;
end;
function TCustomTestLFMTrees.AddFormUnit(const Fields: array of string;
const aFormClass: string; const aFilename: string): TCodeBuffer;
var
Src: String;
i: Integer;
begin
Src:='';
for i:=low(Fields) to high(Fields) do begin
Src:=Src+' '+Fields[i]+';'+sLineBreak;
end;
FUnitCode:=AddSource(aFilename,LinesToStr([
'unit Unit1;',
'{$mode objfpc}{$H+}',
'interface',
'uses Controls;',
'type',
' '+aFormClass+'1 = class('+aFormClass+')',
Src+' end;',
'implementation',
'end.'
]));
Result:=FUnitCode;
end;
function TCustomTestLFMTrees.AddSource(aFilename, aSource: string): TCodeBuffer;
begin
Result:=CodeToolBoss.CreateFile(aFilename);
FSources.Add(Result);
Result.Source:=aSource;
end;
@ -129,12 +171,20 @@ end;
procedure TCustomTestLFMTrees.CheckLFM;
var
LFMTree: TLFMTree;
LFMErr: TLFMError;
begin
LFMTree:=nil;
try
if CodeToolBoss.CheckLFM(UnitCode,LFMCode,LFMTree,true,true,true) then
exit;
WriteSource(CodeXYPosition(CodeToolBoss.ErrorColumn,CodeToolBoss.ErrorLine,CodeToolBoss.ErrorCode));
if LFMTree<>nil then begin
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
writeln('LFM Error: (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
LFMErr:=LFMErr.NextError;
end;
end;
Fail('CheckLFM error "'+CodeToolBoss.ErrorMessage+'"');
finally
LFMTree.Free;
@ -189,18 +239,20 @@ procedure TCustomTestLFMTrees.WriteSource(const CursorPos: TCodeXYPosition);
end else begin
if (CurCode=CursorPos.Code) then continue;
end;
writeln('WriteSources ',i,'/',SourceCount,' ',CurCode.Filename);
for LineNo:=1 to CurCode.LineCount do begin
Line:=CurCode.GetLine(i-1,false);
if (CurCode=CursorPos.Code) and (i=CursorPos.Y) then begin
Line:=CurCode.GetLine(LineNo-1,false);
if (CurCode=CursorPos.Code) and (LineNo=CursorPos.Y) then begin
write('*');
Line:=LeftStr(Line,CursorPos.X-1)+'|'+copy(Line,CursorPos.X,length(Line));
end;
writeln(Format('%:4d: ',[i]),Line);
writeln(Format('%:4d: ',[LineNo]),Line);
end;
end;
end;
begin
writeln('TCustomTestLFMTrees.WriteSource CursorPos=',dbgs(CursorPos));
// write good sources
MyWriteSources(false);
// write error source
@ -211,17 +263,8 @@ end;
procedure TTestLFMTrees.LFMEmptyForm;
begin
FUnitCode:=AddSource('unit1.pas',LinesToStr([
'unit Unit1;',
'{$mode objfpc}{$H+}',
'interface',
'uses Controls;',
'type',
' TForm1 = class(TForm)',
' end;',
'implementation',
'end.'
]));
AddControls;
AddFormUnit([]);
FLFMCode:=AddSource('unit1.lfm',LinesToStr([
'object Form1: TForm1',
'end'
@ -229,6 +272,22 @@ begin
CheckLFM;
end;
procedure TTestLFMTrees.LFMButton1;
begin
AddControls;
AddFormUnit(['Button1: TButton']);
FLFMCode:=AddSource('unit1.lfm',LinesToStr([
'object Form1: TForm1',
' Left = 300',
' object Button1: TButton',
' Caption = ''ClickMe''',
' Default = True',
' end',
'end'
]));
CheckLFM;
end;
initialization
RegisterTest(TTestLFMTrees);