codetools: test CheckLFM child component

components/codetools/tests/testlfmtrees.pas

@@ -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);
+        Line:=CurCode.GetLine(LineNo-1,false);
-        if (CurCode=CursorPos.Code) and (i=CursorPos.Y) then begin
+        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([
+  AddControls;
-    'unit Unit1;',
+  AddFormUnit([]);
-    '{$mode objfpc}{$H+}',
-    'interface',
-    'uses Controls;',
-    'type',
-    '  TForm1 = class(TForm)',
-    '  end;',
-    'implementation',
-    'end.'
-    ]));
   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);