tests: added gui test runner for running test projects and first testcase based on a bug report

git-svn-id: trunk@10541 -
2025-08-18 12:59:14 +02:00 · 2007-01-30 22:45:54 +00:00 · 2007-01-30 22:45:54 +00:00 · 2bdbe6f91c
commit 2bdbe6f91c
parent 7ef1dc90d4
10 changed files with 495 additions and 0 deletions
--- a/.gitattributes
+++ b/.gitattributes
@ -2816,6 +2816,15 @@ packager/ucomponentmanmain.pas svneol=native#text/pascal
 packager/ufrmaddcomponent.lfm svneol=native#text/plain
 packager/ufrmaddcomponent.lrs svneol=native#text/pascal
 packager/ufrmaddcomponent.pas svneol=native#text/pascal
+test/bugs/7462/bug7462.lpi svneol=native#text/plain
+test/bugs/7462/bug7462.lpr svneol=native#text/plain
+test/bugs/7462/expected.txt svneol=native#text/plain
+test/bugs/7462/unit1.lfm svneol=native#text/plain
+test/bugs/7462/unit1.lrs svneol=native#text/plain
+test/bugs/7462/unit1.pas svneol=native#text/plain
+test/bugs/bugtestcase.pas svneol=native#text/plain
+test/bugs/runbugtestcases.lpi svneol=native#text/plain
+test/bugs/runbugtestcases.lpr svneol=native#text/plain
 test/hello.ahk svneol=native#text/plain
 test/readme.txt svneol=native#text/plain
 test/runtests.lpi svneol=native#text/plain
--- a/test/bugs/7462/bug7462.lpi
+++ b/test/bugs/7462/bug7462.lpi
@ -0,0 +1,73 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="\"/>
+    <Version Value="5"/>
+    <General>
+      <SessionStorage Value="InIDEConfig"/>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=".exe"/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="FCL"/>
+        <MinVersion Major="1" Valid="True"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="3">
+      <Unit0>
+        <Filename Value="bug7462.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="bug7462"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <ComponentName Value="Form1"/>
+        <IsPartOfProject Value="True"/>
+        <ResourceFilename Value="unit1.lrs"/>
+        <UnitName Value="Unit1"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="expected.txt"/>
+        <IsPartOfProject Value="True"/>
+      </Unit2>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <PathDelim Value="\"/>
+    <SearchPaths>
+      <SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Linking>
+      <Debugging>
+        <UseLineInfoUnit Value="False"/>
+      </Debugging>
+    </Linking>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>
--- a/test/bugs/7462/bug7462.lpr
+++ b/test/bugs/7462/bug7462.lpr
@ -0,0 +1,18 @@
+program bug7462;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms
+  { add your units here }, Unit1;
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+
--- a/test/bugs/7462/expected.txt
+++ b/test/bugs/7462/expected.txt
@ -0,0 +1 @@
+Memo length: 0
--- a/test/bugs/7462/unit1.lfm
+++ b/test/bugs/7462/unit1.lfm
@ -0,0 +1,32 @@
+object Form1: TForm1
+  Left = 290
+  Height = 122
+  Top = 175
+  Width = 242
+  HorzScrollBar.Page = 241
+  VertScrollBar.Page = 121
+  ActiveControl = Memo1
+  Caption = 'Form1'
+  OnCreate = FormCreate
+  object Memo1: TMemo
+    Left = 24
+    Height = 90
+    Top = 16
+    Width = 150
+    Lines.Strings = (
+      'Memo1'
+    )
+    TabOrder = 0
+  end
+  object ApplicationProperties1: TApplicationProperties
+    CaptureExceptions = True
+    HintColor = clInfoBk
+    HintHidePause = 2500
+    HintPause = 500
+    HintShortCuts = True
+    ShowHint = True
+    OnIdle = ApplicationProperties1Idle
+    left = 16
+    top = 192
+  end
+end
--- a/test/bugs/7462/unit1.lrs
+++ b/test/bugs/7462/unit1.lrs
@ -0,0 +1,13 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TForm1','FORMDATA',[
+  'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'"'#1#6'Height'#2'z'#3'Top'#3#175#0#5'Widt'
+  +'h'#3#242#0#18'HorzScrollBar.Page'#3#241#0#18'VertScrollBar.Page'#2'y'#13'Ac'
+  +'tiveControl'#7#5'Memo1'#7'Caption'#6#5'Form1'#8'OnCreate'#7#10'FormCreate'#0
+  +#5'TMemo'#5'Memo1'#4'Left'#2#24#6'Height'#2'Z'#3'Top'#2#16#5'Width'#3#150#0
+  +#13'Lines.Strings'#1#6#5'Memo1'#0#8'TabOrder'#2#0#0#0#22'TApplicationPropert'
+  +'ies'#22'ApplicationProperties1'#17'CaptureExceptions'#9#9'HintColor'#7#8'cl'
+  +'InfoBk'#13'HintHidePause'#3#196#9#9'HintPause'#3#244#1#13'HintShortCuts'#9#8
+  +'ShowHint'#9#6'OnIdle'#7#26'ApplicationProperties1Idle'#4'left'#2#16#3'top'#3
+  +#192#0#0#0#0
+]);
--- a/test/bugs/7462/unit1.pas
+++ b/test/bugs/7462/unit1.pas
@ -0,0 +1,47 @@
+unit Unit1; 
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    ApplicationProperties1: TApplicationProperties;
+    Memo1: TMemo;
+    procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
+    procedure FormCreate(Sender: TObject);
+  private
+    { private declarations }
+  public
+    { public declarations }
+  end; 
+
+var
+  Form1: TForm1; 
+
+implementation
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  Memo1.Clear;
+end;
+
+procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
+begin
+  writeln('Memo length: ', Length(Memo1.Text));
+  Close;
+end;
+
+initialization
+  {$I unit1.lrs}
+
+end.
+
--- a/test/bugs/bugtestcase.pas
+++ b/test/bugs/bugtestcase.pas
@ -0,0 +1,228 @@
+unit BugTestCase;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Math, process, fileutil, fpcunit, testutils, testregistry;
+
+type
+
+  { TBugTestCase }
+
+  TBugTestCase= class(TTestCase)
+  private
+    FPath: string;
+    FProjectFile: string;
+  protected
+    procedure SetUp; override; 
+    procedure TearDown; override;
+  public
+    constructor Create(APath, ATestName: string); reintroduce;
+    class function CreateSuite(Path: string) : TTestSuite;
+  published
+    procedure Compile;
+    procedure RunTestApp;
+    procedure CompareExpectations;
+    procedure HeaptrcLog;
+  end; 
+  
+var
+  Compiler: string;
+
+implementation
+
+var
+  BufferedOutput: TMemoryStream; // a global variable is not nice, but it works.
+  
+const
+  READ_BYTES = 2048;
+
+procedure ReadOutput(AProcess:TProcess);
+var
+  BytesRead: Integer;
+  n: Integer;
+begin
+  BytesRead := 0;
+  BufferedOutput.Clear;
+  while AProcess.Running do
+  begin
+    // make sure we have room
+    BufferedOutput.SetSize(BytesRead + READ_BYTES);
+
+    // try reading it
+    n := AProcess.Output.Read((BufferedOutput.Memory + BytesRead)^, READ_BYTES);
+    if n > 0 then
+      Inc(BytesRead, n)
+    else
+      // no data, wait 100 ms
+      Sleep(100);
+  end;
+  // read last part
+  repeat
+    // make sure we have room
+    BufferedOutput.SetSize(BytesRead + READ_BYTES);
+    // try reading it
+    n := AProcess.Output.Read((BufferedOutput.Memory + BytesRead)^, READ_BYTES);
+    if n > 0 then
+      Inc(BytesRead, n);
+  until n <= 0;
+  BufferedOutput.SetSize(BytesRead);
+end;
+
+function FindProjectFile(APath: string):string;
+var
+  SearchRec: TSearchRec;
+begin
+  if FindFirst(AppendPathDelim(APath)+'*.lpi', faAnyFile, SearchRec)=0 then begin
+    repeat
+      if ExtractFileExt(SearchRec.Name)='.lpi' then
+        Result := SearchRec.Name;
+    until (Length(Result)>0) or (FindNext(SearchRec)<>0);
+  end;
+  FindClose(SearchRec);
+  if length(Result)>0 then
+    Result := AppendPathDelim(APath) + Result;
+end;
+
+procedure TBugTestCase.Compile;
+var
+  LazBuildPath: string;
+  LazBuild: TProcess;
+  LazarusDir: String;
+begin
+  AssertTrue('Project file '+ FProjectFile + ' does not exist',
+    FileExists(FProjectFile));
+  LazarusDir := ExpandFileName(ExtractFilePath(ParamStr(0)) + '../../');
+  LazBuildPath := LazarusDir + 'lazbuild' + GetExeExt;
+  AssertTrue(LazBuildPath + ' does not exist', FileExists(LazBuildPath));
+  LazBuild := TProcess.Create(nil);
+  try
+    {$IFDEF win32}
+    LazBuild.Options := [poNewConsole];
+    {$ELSE}
+    LazBuild.Options := [poNoConsole];
+    {$ENDIF}
+    LazBuild.ShowWindow := swoHIDE;
+    LazBuild.CommandLine := LazBuildPath;
+    if Compiler<>'' then
+      LazBuild.CommandLine := LazBuild.CommandLine + ' --compiler='+Compiler;
+    LazBuild.CommandLine := LazBuild.CommandLine + ' ' + FProjectFile;
+    LazBuild.CurrentDirectory := FPath;
+    LazBuild.Execute;
+    LazBuild.WaitOnExit;
+    AssertEquals('Compilation failed: ExitCode', 0, LazBuild.ExitStatus);
+  finally
+    LazBuild.Free;
+  end;
+end;
+
+procedure TBugTestCase.RunTestApp;
+var
+  TestProcess : TProcess;
+  ExeName: string;
+begin
+  ExeName := ChangeFileExt(FProjectFile, GetExeExt);
+  AssertTrue(ExeName + 'does not exist.', FileExists(ExeName));
+  TestProcess := TProcess.Create(nil);
+  try
+    TestProcess.CommandLine := ExeName;
+    TestProcess.Options := [poUsePipes];
+    TestProcess.Execute;
+    //RunScript;
+    ReadOutput(TestProcess);
+  finally
+    TestProcess.Free;
+  end;
+end;
+
+procedure TBugTestCase.CompareExpectations;
+var
+  ExpectedFileName: string;
+  ExpectedLines: TStrings;
+  ActualLines: TStrings;
+  MinLineCount: integer;
+  i: integer;
+begin
+  ExpectedFileName := AppendPathDelim(FPath) + 'Expected.txt';
+  AssertTrue('File missing: '+ExpectedFileName, FileExists(ExpectedFileName));
+  ExpectedLines := nil;
+  ActualLines := nil;
+  try
+    ExpectedLines := TStringList.Create;
+    ExpectedLines.LoadFromFile(ExpectedFileName);
+    BufferedOutput.Position := 0;
+    ActualLines  := TStringList.Create;
+    ActualLines.LoadFromStream(BufferedOutput);
+    MinLineCount := min(ExpectedLines.Count, ActualLines.Count);
+    for i := 0 to MinLineCount - 1 do begin
+      AssertEquals('Output difference on line '+IntToStr(i+1),
+        ExpectedLines[i], ActualLines[i]);
+    end;
+    AssertEquals('Difference in line count',
+      ExpectedLines.Count, ActualLines.Count);
+  finally
+    ExpectedLines.Free;
+    ActualLines.Free;
+  end;
+end;
+
+procedure TBugTestCase.HeaptrcLog;
+begin
+
+end;
+
+procedure TBugTestCase.SetUp; 
+begin
+end; 
+
+procedure TBugTestCase.TearDown; 
+begin
+end;
+
+constructor TBugTestCase.Create(APath, ATestName: string);
+begin
+  CreateWithName(ATestName);
+  FPath := APath;
+  FProjectFile := FindProjectFile(FPath);
+  writeln(FProjectFile);
+end;
+
+class function TBugTestCase.CreateSuite(Path: string): TTestSuite;
+var
+  Directory: string;
+begin
+  Directory := ExtractFileName(Path);
+  Result := TTestSuite.Create(Directory);
+  Result.AddTest(Create(Path, 'Compile'));
+  Result.AddTest(Create(Path, 'RunTestApp'));
+  Result.AddTest(Create(Path, 'CompareExpectations'));
+  Result.AddTest(Create(Path, 'HeaptrcLog'));
+end;
+
+procedure GatherTests;
+var
+  ProgPath: string;
+  SearchRec: TSearchRec;
+begin
+  ProgPath := ExtractFilePath(ParamStr(0));
+  if FindFirst(ProgPath+'*', faAnyFile, SearchRec)=0 then
+    repeat
+      if (SearchRec.Attr=faDirectory) and
+         (SearchRec.Name<>'.') and (SearchRec.Name<>'..')
+      then
+        GetTestRegistry.AddTest(
+          TBugTestCase.CreateSuite(ProgPath+SearchRec.Name));
+    until FindNext(SearchRec)<>0;
+  FindClose(SearchRec);
+end;
+
+initialization
+  GatherTests;
+  BufferedOutput := TMemoryStream.Create;
+  
+finalization
+  FreeAndNil(BufferedOutput);
+end.
+
--- a/test/bugs/runbugtestcases.lpi
+++ b/test/bugs/runbugtestcases.lpi
@ -0,0 +1,61 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="\"/>
+    <Version Value="5"/>
+    <General>
+      <SessionStorage Value="InIDEConfig"/>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=".exe"/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="3">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="FPCUnitTestRunner"/>
+      </Item2>
+      <Item3>
+        <PackageName Value="FCL"/>
+      </Item3>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="runbugtestcases.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="runbugtestcases"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="bugtestcase.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="BugTestCase"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <PathDelim Value="\"/>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>
--- a/test/bugs/runbugtestcases.lpr
+++ b/test/bugs/runbugtestcases.lpr
@ -0,0 +1,13 @@
+program runbugtestcases;
+
+{$mode objfpc}{$H+}
+
+uses
+  Interfaces, Forms, GuiTestRunner, BugTestCase;
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TGuiTestRunner, TestRunner);
+  Application.Run;
+end.
+