MindStream. Как мы пишем ПО под FireMonkey. Часть 5. Тестирование

Часть 1.
Часть 2.
Часть 3. DUnit + FireMonkey
Часть 3.1. По мотивам GUIRunner
Часть 4. Serialization

Здравствуйте, дорогиее.

В этом посте я хочу рассказать об изменениях, которые произошли с нашим проектом, а также о технологиях и приемах, которые мы использовали для достижения наших целей.

Сейчас наш проект выглядит так:

Диаграмму можно сохранить в Json, а также восстановить из Json, о чём я писал в предыдущей статье.

{
	"type": "msDiagramms.TmsDiagramms",
	"id": 1,
	"fields": {
		"f_Items": [{
			"type": "msDiagramm.TmsDiagramm",
			"id": 2,
			"fields": {
				"fName": "¹1",
				"f_Items": [{
					"type": "msRoundedRectangle.TmsRoundedRectangle",
					"id": 3,
					"fields": {
						"FStartPoint": [[110,
						186],
						110,
						186],
						"f_Items": []
					}
				},
				{
					"type": "msRoundedRectangle.TmsRoundedRectangle",
					"id": 4,
					"fields": {
						"FStartPoint": [[357,
						244],
						357,
						244],
						"f_Items": []
					}
				},
				{
					"type": "msTriangle.TmsTriangle",
					"id": 5,
					"fields": {
						"FStartPoint": [[244,
						58],
						244,
						58],
						"f_Items": []
					}
				},
				{
					"type": "msLineWithArrow.TmsLineWithArrow",
					"id": 6,
					"fields": {
						"FFinishPoint": [[236,
						110],
						236,
						110],
						"FStartPoint": [[156,
						175],
						156,
						175],
						"f_Items": []
					}
				},
				{
					"type": "msLineWithArrow.TmsLineWithArrow",
					"id": 7,
					"fields": {
						"FFinishPoint": [[262,
						109],
						262,
						109],
						"FStartPoint": [[327,
						199],
						327,
						199],
						"f_Items": []
					}
				},
				{
					"type": "msUseCaseLikeEllipse.TmsUseCaseLikeEllipse",
					"id": 8,
					"fields": {
						"FStartPoint": [[52,
						334],
						52,
						334],
						"f_Items": []
					}
				},
				{
					"type": "msUseCaseLikeEllipse.TmsUseCaseLikeEllipse",
					"id": 9,
					"fields": {
						"FStartPoint": [[171,
						336],
						171,
						336],
						"f_Items": []
					}
				},
				{
					"type": "msLineWithArrow.TmsLineWithArrow",
					"id": 10,
					"fields": {
						"FFinishPoint": [[98,
						232],
						98,
						232],
						"FStartPoint": [[62,
						300],
						62,
						300],
						"f_Items": []
					}
				},
				{
					"type": "msLineWithArrow.TmsLineWithArrow",
					"id": 11,
					"fields": {
						"FFinishPoint": [[133,
						233],
						133,
						233],
						"FStartPoint": [[167,
						299],
						167,
						299],
						"f_Items": []
					}
				},
				{
					"type": "msRectangle.TmsRectangle",
					"id": 12,
					"fields": {
						"FStartPoint": [[302,
						395],
						302,
						395],
						"f_Items": []
					}
				},
				{
					"type": "msRectangle.TmsRectangle",
					"id": 13,
					"fields": {
						"FStartPoint": [[458,
						389],
						458,
						389],
						"f_Items": []
					}
				},
				{
					"type": "msLineWithArrow.TmsLineWithArrow",
					"id": 14,
					"fields": {
						"FFinishPoint": [[361,
						292],
						361,
						292],
						"FStartPoint": [[308,
						351],
						308,
						351],
						"f_Items": []
					}
				},
				{
					"type": "msLineWithArrow.TmsLineWithArrow",
					"id": 15,
					"fields": {
						"FFinishPoint": [[389,
						292],
						389,
						292],
						"FStartPoint": [[455,
						344],
						455,
						344],
						"f_Items": []
					}
				},
				{
					"type": "msCircle.TmsCircle",
					"id": 16,
					"fields": {
						"FStartPoint": [[58,
						51],
						58,
						51],
						"f_Items": []
					}
				},
				{
					"type": "msLineWithArrow.TmsLineWithArrow",
					"id": 17,
					"fields": {
						"FFinishPoint": [[88,
						94],
						88,
						94],
						"FStartPoint": [[108,
						141],
						108,
						141],
						"f_Items": []
					}
				}]
			}
		}]
	}
}

Каждая фигура стала обладать возможностью “быть диаграммой”. То есть, мы можем выбрать фигуру и построить “внутри” новую диаграмму. Более наглядно продемонстрировано ниже.

Объект TmsPicker отвечает за возможность “проваливания внутрь”. Объект TmsUpToParrent отвечает за возвращение к родительской диаграмме.

Также у нас появился ToolBar, в котором динамически рисуются все фигуры, предназначенные для рисования, и реализована возможность создавать специальные фигуры, например, для объекта перемещения (под красным квадратом):

Также нами был реализован контроль за созданиемосвобождением объектов. Детальное описание
тут.
После окончания работы приложения получаем такой лог:

Ну и самое главное, часть кода мы покрыли тестами. На сегодняшний день их 174.

При этом на тестах сохранения в PNG рождаются такие рисунки:

Размер “эталона” проверки рисований красного круга: 1048x2049 пикселей. Размер файла 1.7 MB.
Однако о деталях дальше.

Начнем в обратном порядке.

Тесты.

Первым делом подключим DUnit к проекту. Для этого добавим одну строчку в проект, после чего он выглядит так:

program MindStream;

uses
  FMX.Forms,
  …
  ;

begin
  Application.Initialize;
  Application.CreateForm(TfmMain, fmMain);
  // Подключаем свой GUI_Runner, который в свою очередь найдет все зарегестрированные тесты
  u_fmGUITestRunner.RunRegisteredTestsModeless;
  Application.Run;
end.

Теперь проверим работоспособность DUnit с помощью FirstTest.

unit FirstTest;

interface

uses
  TestFrameWork;

type
  TFirstTest = class(TTestCase)
  published
    procedure DoIt;
  end; // TFirstTest

implementation

uses
  SysUtils;

procedure TFirstTest.DoIt;
begin
  Check(true);
end;

initialization

TestFrameWork.RegisterTest(TFirstTest.Suite);

end.

Следующим шагом добавим первые тесты, однако сразу разделим их по классификации:
интеграционные;
модульные.

Начнем с интеграционных. Первым тестом узнаем, все ли наши фигуры зарегистрированы:

unit RegisteredShapesTest;

interface

uses
  TestFrameWork;

type
  TRegisteredShapesTest = class(TTestCase)
  published
    procedure ShapesRegistredCount;
    procedure TestFirstShape;
    procedure TestIndexOfTmsLine;
  end; // TRegisteredShapesTest

implementation

uses
  SysUtils,
  msRegisteredShapes,
  msShape,
  msLine,
  FMX.Objects,
  FMX.Graphics;

procedure TRegisteredShapesTest.ShapesRegistredCount;
var
  l_Result: integer;
begin
  l_Result := 0;
  TmsRegisteredShapes.IterateShapes(
    procedure(aShapeClass: RmsShape)
    begin
      Inc(l_Result);
    end);
  CheckTrue(l_Result = 23, ' Expected 23 - Get ' + IntToStr(l_Result));
end;

procedure TRegisteredShapesTest.TestFirstShape;
begin
  CheckTrue(TmsRegisteredShapes.Instance.First = TmsLine);
end;

procedure TRegisteredShapesTest.TestIndexOfTmsLine;
begin
  CheckTrue(TmsRegisteredShapes.Instance.IndexOf(TmsLine) = 0);
end;

initialization
  TestFrameWork.RegisterTest(TRegisteredShapesTest.Suite);
end.

Ещё два подобных теста напишем для проверки количества фигур, которые нам необходимы:

...
type
  TUtilityShapesTest = class(TTestCase)
  published
    procedure ShapesRegistredCount;
    procedure TestFirstShape;
    procedure TestIndexOfTmsLine;
  end; // TUtilityShapesTest
...
procedure TUtilityShapesTest.ShapesRegistredCount;
var
  l_Result: integer;
begin
  l_Result := 0;
  TmsUtilityShapes.IterateShapes(
    procedure(aShapeClass: RmsShape)
    begin
      Assert(aShapeClass.IsForToolbar);
      Inc(l_Result);
    end);
  CheckTrue(l_Result = 5, ' Expected 5 - Get ' + IntToStr(l_Result));
end;
…
  TForToolbarShapesTest = class(TTestCase)
  published
    procedure ShapesRegistredCount;
    procedure TestFirstShape;
    procedure TestIndexOfTmsLine;
  end; // TForToolbarShapesTest

procedure TForToolbarShapesTest.ShapesRegistredCount;
var
  l_Result: integer;
begin
  l_Result := 0;
  TmsShapesForToolbar.IterateShapes(
    procedure(aShapeClass: RmsShape)
    begin
      Assert(aShapeClass.IsForToolbar);
      Inc(l_Result);
    end);
  CheckTrue(l_Result = 18, ' Expected 18 - Get ' + IntToStr(l_Result));
end;

Теперь перейдем к модульным.
Для начала напишем базовый класс модульного теста.

type
  TmsShapeClassCheck = TmsShapeClassLambda;

  TmsDiagrammCheck = reference to procedure(const aDiagramm: ImsDiagramm);
  TmsDiagrammSaveTo = reference to procedure(const aFileName: String; const aDiagramm: ImsDiagramm);

    // контекст тестирования хранит в себе всю уникальную информацию для  каждого теста
  TmsShapeTestContext = record
    rMethodName: string;
    rSeed: Integer;
    rDiagrammName: String;
    rShapesCount: Integer;
    rShapeClass: RmsShape;
    constructor Create(aMethodName: string;
    aSeed: Integer; aDiagrammName: string; aShapesCount: Integer; aShapeClass: RmsShape);
  end; // TmsShapeTestContext

  TmsShapeTestPrim = class abstract(TTestCase)
  protected
    // контекст тестирования хранит в себе всю уникальную информацию для  каждого теста
    f_Context: TmsShapeTestContext;
    f_TestSerializeMethodName: String;
    f_Coords: array of TPoint;
  protected
    class function ComputerName: AnsiString;
    function TestResultsFileName: String; virtual;
    function MakeFileName(const aTestName: string; const aTestFolder: string): String; virtual;
    procedure CreateDiagrammAndCheck(aCheck: TmsDiagrammCheck; const aName: String);
    // Процедура проверки результатов теста с эталонном
    procedure CheckFileWithEtalon(const aFileName: String);
    procedure SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm); virtual;
    procedure SaveDiagrammAndCheck(const aDiagramm: ImsDiagramm; aSaveTo: TmsDiagrammSaveTo);
    procedure OutToFileAndCheck(aLambda: TmsLogLambda);
    procedure SetUp; override;
    function ShapesCount: Integer;
    procedure CreateDiagrammWithShapeAndSaveAndCheck;
    function TestSerializeMethodName: String;
    procedure DeserializeDiargammAndCheck(aCheck: TmsDiagrammCheck);
    procedure TestDeSerializeForShapeClass;
    procedure TestDeSerializeViaShapeCheckForShapeClass;
  public
    class procedure CheckShapes(aCheck: TmsShapeClassCheck);
    constructor Create(const aContext: TmsShapeTestContext);
  end; // TmsShapeTestPrim

function TmsShapeTestPrim.MakeFileName(const aTestName: string; const aTestFolder: string): String;
var
  l_Folder: String;
begin
  l_Folder := ExtractFilePath(ParamStr(0)) + 'TestResults' + aTestFolder;
  ForceDirectories(l_Folder);
  Result := l_Folder + ClassName + '_' + aTestName + '_' + f_Context.rShapeClass.ClassName;
end;

procedure TmsShapeTestPrim.CheckFileWithEtalon(const aFileName: String);
var
  l_FileNameEtalon: String;
begin
  l_FileNameEtalon := aFileName + '.etalon' + ExtractFileExt(aFileName);
  if FileExists(l_FileNameEtalon) then
  begin
    CheckTrue(msCompareFiles(l_FileNameEtalon, aFileName));
  end // FileExists(l_FileNameEtalon)
  else
  begin
    CopyFile(PWideChar(aFileName), PWideChar(l_FileNameEtalon), True);
  end; // FileExists(l_FileNameEtalon)
end;

const
  c_JSON = 'JSON';

function TmsShapeTestPrim.TestResultsFileName: String;
begin
  Result := MakeFileName(Name, c_JSON);
end;

class function TmsShapeTestPrim.ComputerName: AnsiString;
var
  l_CompSize: Integer;
begin
  l_CompSize := MAX_COMPUTERNAME_LENGTH + 1;
  SetLength(Result, l_CompSize);

  Win32Check(GetComputerNameA(PAnsiChar(Result), LongWord(l_CompSize)));
  SetLength(Result, l_CompSize);
end;

procedure TmsShapeTestPrim.SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm);
begin
  aDiagramm.SaveTo(aFileName);
end;

procedure TmsShapeTestPrim.SaveDiagrammAndCheck(const aDiagramm: ImsDiagramm; aSaveTo: TmsDiagrammSaveTo);
var
  l_FileNameTest: String;
begin
  l_FileNameTest := TestResultsFileName;
  aSaveTo(l_FileNameTest, aDiagramm);
  CheckFileWithEtalon(l_FileNameTest);
end;

function TmsShapeTestPrim.ShapesCount: Integer;
begin
  Result := f_Context.rShapesCount;
end;

constructor TmsShapeTestContext.Create(aMethodName: string; aSeed: Integer; aDiagrammName: string; aShapesCount: Integer;
  aShapeClass: RmsShape);
begin
  rMethodName := aMethodName;
  rSeed := aSeed;
  rDiagrammName := aDiagrammName;
  rShapesCount := aShapesCount;
  rShapeClass := aShapeClass;
end;

procedure TmsShapeTestPrim.SetUp;
var
  l_Index: Integer;
  l_X: Integer;
  l_Y: Integer;
begin
  inherited;
  RandSeed := f_Context.rSeed;
  SetLength(f_Coords, ShapesCount);
  for l_Index := 0 to Pred(ShapesCount) do
  begin
    l_X := Random(c_MaxCanvasWidth);
    l_Y := Random(c_MaxCanvasHeight);
    f_Coords[l_Index] := TPoint.Create(l_X, l_Y);
  end; // for l_Index
end;

procedure TmsShapeTestPrim.CreateDiagrammAndCheck(aCheck: TmsDiagrammCheck; const aName: String);
var
  l_Diagramm: ImsDiagramm;
begin
  l_Diagramm := TmsDiagramm.Create(aName);
  try
    aCheck(l_Diagramm);
  finally
    l_Diagramm := nil;
  end; // try..finally
end;

procedure TmsShapeTestPrim.CreateDiagrammWithShapeAndSaveAndCheck;
begin
  CreateDiagrammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    var
      l_P: TPoint;
    begin
      for l_P in f_Coords do
        aDiagramm.AddShape(TmsCompletedShapeCreator.Create(f_Context.rShapeClass)
          .CreateShape(TmsMakeShapeContext.Create(TPointF.Create(l_P.X, l_P.Y), nil, nil))).AddNewDiagramm;

      SaveDiagrammAndCheck(aDiagramm, SaveDiagramm);
    end, f_Context.rDiagrammName);
end;

function TmsCustomShapeTest.MakeFileName(const aTestName: string; const aFileExtension: string): String;
begin
  Result := inherited + '.json';
end;

function TmsShapeTestPrim.TestSerializeMethodName: String;
begin
  Result := f_TestSerializeMethodName + 'TestSerialize';
end;

procedure TmsShapeTestPrim.DeserializeDiargammAndCheck(aCheck: TmsDiagrammCheck);
begin
  CreateDiagrammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    begin
      aDiagramm.LoadFrom(MakeFileName(TestSerializeMethodName, c_JSON));
      // - берём результаты от ПРЕДЫДУЩИХ тестов, НЕКОШЕРНО с точки зрения TDD
      // НО! Чертовски эффективно.
      aCheck(aDiagramm);
    end, '');
end;

procedure TmsShapeTestPrim.TestDeSerializeForShapeClass;
begin
  DeserializeDiargammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    begin
      SaveDiagrammAndCheck(aDiagramm, SaveDiagramm);
    end);
end;

constructor TmsShapeTestPrim.Create(const aContext: TmsShapeTestContext);
begin
  inherited Create(aContext.rMethodName);
  f_Context := aContext;
  FTestName := f_Context.rShapeClass.ClassName + '.' + aContext.rMethodName;
  f_TestSerializeMethodName := f_Context.rShapeClass.ClassName + '.';
end;

procedure TmsShapeTestPrim.TestDeSerializeViaShapeCheckForShapeClass;
begin
  DeserializeDiargammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    var
      l_Shape: ImsShape;
      l_Index: Integer;
    begin
      Check(aDiagramm.Name = f_Context.rDiagrammName);
      Check(Length(f_Coords) = aDiagramm.ItemsCount);
      l_Index := 0;
      for l_Shape in aDiagramm do
      begin
        Check(l_Shape.ClassType = f_Context.rShapeClass);
        Check(l_Shape.StartPoint.X = f_Coords[l_Index].X);
        Check(l_Shape.StartPoint.Y = f_Coords[l_Index].Y);
        Inc(l_Index);
      end; // for l_Shape
    end);
end;

procedure TmsShapeTestPrim.OutToFileAndCheck(aLambda: TmsLogLambda);
var
  l_FileNameTest: String;
begin
  l_FileNameTest := TestResultsFileName;
  TmsLog.Log(l_FileNameTest,
    procedure(aLog: TmsLog)
    begin
      aLambda(aLog);
    end);
  CheckFileWithEtalon(l_FileNameTest);
end;

class procedure TmsShapeTestPrim.CheckShapes(aCheck: TmsShapeClassCheck);
begin
  TmsRegisteredShapes.IterateShapes(
    procedure(aShapeClass: RmsShape)
    begin
      if not aShapeClass.IsTool then
        aCheck(aShapeClass);
    end);
end;

Ну а теперь кратко о том, как это все работает.
Хоть наш класс, хоть и является абстрактным, однако вся логика спрятана именно тут. Он унаследован от TTestCase из DUnit, а значит, при желании, любой потомок сможет быть зарегистрирован для тестирования, реализуя, благодаря наследованию, уникальные настройки, которые не входят в контекст.

Сам смыл тестирования (как мы его видим; и это совсем не TDD) мы очень детально описали на примере тестирования простейшего калькулятора в нашем блоге.

В двух словах — использование тестирования с помощью эталонов предполагает сохранение значений и результата теста в файл, который мы затем сравниваем с эталонным. Если файлы не совпадают, то тест “провалился”. Тут возникает вопрос: откуда мы возьмем эталонный файл? И здесь у нас два варианта: либо мы его создадим руками, либо (как поступил я) если эталона не существует, то мы создаем его автоматически на основе файла результата тестирования, так как допускаем (проверяем вручную по старинке на глаз), что тесты у нас заведомо правильные.

Как заметил внимательный читатель, в классе вовсю используются лямбды и анонимные методы. Это, для нас, один из способов поддерживать принцип DRY, там, где этого недостаточно, мы используем — наследование. Не скажу, кто из них главный (скорее, важна комбинация и умение распознать, где какой прием лучше), но могу точно сказать — мы придерживаемся принципа на 95%. Остальные 5, скорее, лень или здравый смысл.

Перестану мучить теорией и покажу классы потомки:

  RmsShapeTest = class of TmsShapeTestPrim;

  TmsCustomShapeTest = class(TmsShapeTestPrim)
  protected
    function MakeFileName(const aTestName: string; const aFileExtension: string): String; override;
  published
    procedure TestSerialize;
  end; // TmsCustomShapeTest

function TmsCustomShapeTest.MakeFileName(const aTestName: string; const aFileExtension: string): String;
begin
  Result := inherited + '.json';
end;

procedure TmsCustomShapeTest.TestSerialize;
begin
  CreateDiagrammWithShapeAndSaveAndCheck;
end;

Как видим, изменилось не много. По сути, мы просто сказали, как изменить имя результата. Сделано так потому, что мы будем использовать базовый класс для всех тестов. Однако, лишь следующие будут проверять сериализацию, другой класс будет “результировать” в *.png.

  TmsDiagrammTest = class(TmsCustomShapeTest)
  protected
    procedure SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm); override;
  published
    procedure TestDeSerialize;
  end; // TmsDiagrammTest

procedure TmsDiagrammTest.SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm);
var
  l_Diagramms: ImsDiagramms;
begin
  l_Diagramms := TmsDiagramms.Create;
  try
    l_Diagramms.AddDiagramm(aDiagramm);
    l_Diagramms.SaveTo(aFileName);
  finally
    l_Diagramms := nil;
  end; // try..finally
end;

procedure TmsDiagrammTest.TestDeSerialize;
var
  l_Diagramms: ImsDiagramms;
  l_FileName: String;
begin
  l_Diagramms := TmsDiagramms.Create;
  try
    l_Diagramms.LoadFrom(MakeFileName(TestSerializeMethodName, c_JSON));
    // - берём результаты от ПРЕДЫДУЩИХ тестов, НЕКОШЕРНО с точки зрения TDD
    // НО! Чертовски эффективно.
    l_FileName := TestResultsFileName;
    l_Diagramms.SaveTo(l_FileName);
    CheckFileWithEtalon(l_FileName);
  finally
    l_Diagramms := nil;
  end; // try..finally
end;

Тест фигур.

  TmsShapeTest = class(TmsCustomShapeTest)
  published
    procedure TestDeSerialize;
    procedure TestDeSerializeViaShapeCheck;
    procedure TestShapeName;
    procedure TestDiagrammName;
  end; // TmsShapeTest

procedure TmsShapeTest.TestDeSerializeViaShapeCheck;
begin
  TestDeSerializeViaShapeCheckForShapeClass;
end;

procedure TmsShapeTest.TestDeSerialize;
begin
  TestDeSerializeForShapeClass;
end;

procedure TmsShapeTest.TestShapeName;
begin
  OutToFileAndCheck(
    procedure(aLog: TmsLog)
    begin
      aLog.ToLog(f_Context.rShapeClass.ClassName);
    end);
end;

procedure TmsShapeTest.TestDiagrammName;
begin
  OutToFileAndCheck(
    procedure(aLog: TmsLog)
    begin
      aLog.ToLog(f_Context.rDiagrammName);
    end);
end;

Про тест сохранения в png, единственная важная строчка тут:

function TTestSaveToPNG.TestResultsFileName: String;
const
  c_PNG = 'PNG';
begin
  // Так как мы с коллегой работаем на разных мониторах, соответственно, с разными расширениями, мы тут немножко читим. Опять же, учитывая здравый смысл. 
  Result := MakeFileName(Name, c_PNG + ComputerName + '');
end;

unit msShapeTest;

interface

uses
  TestFramework,
  msDiagramm,
  msShape,
  msRegisteredShapes,
  System.Types,
  System.Classes,
  msCoreObjects,
  msInterfaces;

type
  TmsShapeClassCheck = TmsShapeClassLambda;

  TmsDiagrammCheck = reference to procedure(const aDiagramm: ImsDiagramm);
  TmsDiagrammSaveTo = reference to procedure(const aFileName: String; const aDiagramm: ImsDiagramm);

  TmsShapeTestContext = record
    rMethodName: string;
    rSeed: Integer;
    rDiagrammName: String;
    rShapesCount: Integer;
    rShapeClass: RmsShape;
    constructor Create(aMethodName: string;
    aSeed: Integer; aDiagrammName: string; aShapesCount: Integer; aShapeClass: RmsShape);
  end; // TmsShapeTestContext

  TmsShapeTestPrim = class abstract(TTestCase)
  protected
    f_Context: TmsShapeTestContext;
    f_TestSerializeMethodName: String;
    f_Coords: array of TPoint;
  protected
    class function ComputerName: AnsiString;
    function TestResultsFileName: String; virtual;
    function MakeFileName(const aTestName: string; const aTestFolder: string): String; virtual;
    procedure CreateDiagrammAndCheck(aCheck: TmsDiagrammCheck; const aName: String);
    procedure CheckFileWithEtalon(const aFileName: String);
    procedure SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm); virtual;
    procedure SaveDiagrammAndCheck(const aDiagramm: ImsDiagramm; aSaveTo: TmsDiagrammSaveTo);
    procedure OutToFileAndCheck(aLambda: TmsLogLambda);
    procedure SetUp; override;
    function ShapesCount: Integer;
    procedure CreateDiagrammWithShapeAndSaveAndCheck;
    function TestSerializeMethodName: String;
    procedure DeserializeDiargammAndCheck(aCheck: TmsDiagrammCheck);
    procedure TestDeSerializeForShapeClass;
    procedure TestDeSerializeViaShapeCheckForShapeClass;
  public
    class procedure CheckShapes(aCheck: TmsShapeClassCheck);
    constructor Create(const aContext: TmsShapeTestContext);
  end; // TmsShapeTestPrim

  RmsShapeTest = class of TmsShapeTestPrim;

  TmsCustomShapeTest = class(TmsShapeTestPrim)
  protected
    function MakeFileName(const aTestName: string; const aFileExtension: string): String; override;
  published
    procedure TestSerialize;
  end; // TmsCustomShapeTest

  TmsDiagrammTest = class(TmsCustomShapeTest)
  protected
    procedure SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm); override;
  published
    procedure TestDeSerialize;
  end; // TmsDiagrammTest

  TmsShapeTest = class(TmsCustomShapeTest)
  published
    procedure TestDeSerialize;
    procedure TestDeSerializeViaShapeCheck;
    procedure TestShapeName;
    procedure TestDiagrammName;
  end; // TmsShapeTest

implementation

uses
  System.SysUtils,
  Winapi.Windows,
  System.Rtti,
  System.TypInfo,
  FMX.Objects,
  msSerializeInterfaces,
  msDiagrammMarshal,
  msDiagrammsMarshal,
  msStringList,
  msDiagramms,
  Math,
  msStreamUtils,
  msTestConstants,
  msShapeCreator,
  msCompletedShapeCreator;

function TmsShapeTestPrim.MakeFileName(const aTestName: string; const aTestFolder: string): String;
var
  l_Folder: String;
begin
  l_Folder := ExtractFilePath(ParamStr(0)) + 'TestResults' + aTestFolder;
  ForceDirectories(l_Folder);
  Result := l_Folder + ClassName + '_' + aTestName + '_' + f_Context.rShapeClass.ClassName;
end;

procedure TmsShapeTestPrim.CheckFileWithEtalon(const aFileName: String);
var
  l_FileNameEtalon: String;
begin
  l_FileNameEtalon := aFileName + '.etalon' + ExtractFileExt(aFileName);
  if FileExists(l_FileNameEtalon) then
  begin
    CheckTrue(msCompareFiles(l_FileNameEtalon, aFileName));
  end // FileExists(l_FileNameEtalon)
  else
  begin
    CopyFile(PWideChar(aFileName), PWideChar(l_FileNameEtalon), True);
  end; // FileExists(l_FileNameEtalon)
end;

const
  c_JSON = 'JSON';

function TmsShapeTestPrim.TestResultsFileName: String;
begin
  Result := MakeFileName(Name, c_JSON);
end;

class function TmsShapeTestPrim.ComputerName: AnsiString;
var
  l_CompSize: Integer;
begin
  l_CompSize := MAX_COMPUTERNAME_LENGTH + 1;
  SetLength(Result, l_CompSize);

  Win32Check(GetComputerNameA(PAnsiChar(Result), LongWord(l_CompSize)));
  SetLength(Result, l_CompSize);
end;

procedure TmsShapeTestPrim.SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm);
begin
  aDiagramm.SaveTo(aFileName);
end;

procedure TmsShapeTestPrim.SaveDiagrammAndCheck(const aDiagramm: ImsDiagramm; aSaveTo: TmsDiagrammSaveTo);
var
  l_FileNameTest: String;
begin
  l_FileNameTest := TestResultsFileName;
  aSaveTo(l_FileNameTest, aDiagramm);
  CheckFileWithEtalon(l_FileNameTest);
end;

function TmsShapeTestPrim.ShapesCount: Integer;
begin
  Result := f_Context.rShapesCount;
end;

constructor TmsShapeTestContext.Create(aMethodName: string; aSeed: Integer; aDiagrammName: string; aShapesCount: Integer;
  aShapeClass: RmsShape);
begin
  rMethodName := aMethodName;
  rSeed := aSeed;
  rDiagrammName := aDiagrammName;
  rShapesCount := aShapesCount;
  rShapeClass := aShapeClass;
end;

procedure TmsShapeTestPrim.SetUp;
var
  l_Index: Integer;
  l_X: Integer;
  l_Y: Integer;
begin
  inherited;
  RandSeed := f_Context.rSeed;
  SetLength(f_Coords, ShapesCount);
  for l_Index := 0 to Pred(ShapesCount) do
  begin
    l_X := Random(c_MaxCanvasWidth);
    l_Y := Random(c_MaxCanvasHeight);
    f_Coords[l_Index] := TPoint.Create(l_X, l_Y);
  end; // for l_Index
end;

procedure TmsShapeTestPrim.CreateDiagrammAndCheck(aCheck: TmsDiagrammCheck; const aName: String);
var
  l_Diagramm: ImsDiagramm;
begin
  l_Diagramm := TmsDiagramm.Create(aName);
  try
    aCheck(l_Diagramm);
  finally
    l_Diagramm := nil;
  end; // try..finally
end;

procedure TmsShapeTestPrim.CreateDiagrammWithShapeAndSaveAndCheck;
begin
  CreateDiagrammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    var
      l_P: TPoint;
    begin
      for l_P in f_Coords do
        aDiagramm.AddShape(TmsCompletedShapeCreator.Create(f_Context.rShapeClass)
          .CreateShape(TmsMakeShapeContext.Create(TPointF.Create(l_P.X, l_P.Y), nil, nil))).AddNewDiagramm;

      SaveDiagrammAndCheck(aDiagramm, SaveDiagramm);
    end, f_Context.rDiagrammName);
end;

function TmsCustomShapeTest.MakeFileName(const aTestName: string; const aFileExtension: string): String;
begin
  Result := inherited + '.json';
end;

procedure TmsCustomShapeTest.TestSerialize;
begin
  CreateDiagrammWithShapeAndSaveAndCheck;
end;

function TmsShapeTestPrim.TestSerializeMethodName: String;
begin
  Result := f_TestSerializeMethodName + 'TestSerialize';
end;

procedure TmsShapeTestPrim.DeserializeDiargammAndCheck(aCheck: TmsDiagrammCheck);
begin
  CreateDiagrammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    begin
      aDiagramm.LoadFrom(MakeFileName(TestSerializeMethodName, c_JSON));
      // - берём результаты от ПРЕДЫДУЩИХ тестов, НЕКОШЕРНО с точки зрения TDD
      // НО! Чертовски эффективно.
      aCheck(aDiagramm);
    end, '');
end;

procedure TmsShapeTestPrim.TestDeSerializeForShapeClass;
begin
  DeserializeDiargammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    begin
      SaveDiagrammAndCheck(aDiagramm, SaveDiagramm);
    end);
end;

procedure TmsShapeTest.TestDeSerialize;
begin
  TestDeSerializeForShapeClass;
end;

constructor TmsShapeTestPrim.Create(const aContext: TmsShapeTestContext);
begin
  inherited Create(aContext.rMethodName);
  f_Context := aContext;
  FTestName := f_Context.rShapeClass.ClassName + '.' + aContext.rMethodName;
  f_TestSerializeMethodName := f_Context.rShapeClass.ClassName + '.';
end;

procedure TmsShapeTestPrim.TestDeSerializeViaShapeCheckForShapeClass;
begin
  DeserializeDiargammAndCheck(
    procedure(const aDiagramm: ImsDiagramm)
    var
      l_Shape: ImsShape;
      l_Index: Integer;
    begin
      Check(aDiagramm.Name = f_Context.rDiagrammName);
      Check(Length(f_Coords) = aDiagramm.ItemsCount);
      l_Index := 0;
      for l_Shape in aDiagramm do
      begin
        Check(l_Shape.ClassType = f_Context.rShapeClass);
        Check(l_Shape.StartPoint.X = f_Coords[l_Index].X);
        Check(l_Shape.StartPoint.Y = f_Coords[l_Index].Y);
        Inc(l_Index);
      end; // for l_Shape
    end);
end;

procedure TmsShapeTest.TestDeSerializeViaShapeCheck;
begin
  TestDeSerializeViaShapeCheckForShapeClass;
end;

procedure TmsShapeTestPrim.OutToFileAndCheck(aLambda: TmsLogLambda);
var
  l_FileNameTest: String;
begin
  l_FileNameTest := TestResultsFileName;
  TmsLog.Log(l_FileNameTest,
    procedure(aLog: TmsLog)
    begin
      aLambda(aLog);
    end);
  CheckFileWithEtalon(l_FileNameTest);
end;

procedure TmsShapeTest.TestShapeName;
begin
  OutToFileAndCheck(
    procedure(aLog: TmsLog)
    begin
      aLog.ToLog(f_Context.rShapeClass.ClassName);
    end);
end;

procedure TmsShapeTest.TestDiagrammName;
begin
  OutToFileAndCheck(
    procedure(aLog: TmsLog)
    begin
      aLog.ToLog(f_Context.rDiagrammName);
    end);
end;

class procedure TmsShapeTestPrim.CheckShapes(aCheck: TmsShapeClassCheck);
begin
  TmsRegisteredShapes.IterateShapes(
    procedure(aShapeClass: RmsShape)
    begin
      if not aShapeClass.IsTool then
        aCheck(aShapeClass);
    end);
end;

// TmsDiagrammTest

procedure TmsDiagrammTest.SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm);
var
  l_Diagramms: ImsDiagramms;
begin
  l_Diagramms := TmsDiagramms.Create;
  try
    l_Diagramms.AddDiagramm(aDiagramm);
    l_Diagramms.SaveTo(aFileName);
  finally
    l_Diagramms := nil;
  end; // try..finally
end;

procedure TmsDiagrammTest.TestDeSerialize;
var
  l_Diagramms: ImsDiagramms;
  l_FileName: String;
begin
  l_Diagramms := TmsDiagramms.Create;
  try
    l_Diagramms.LoadFrom(MakeFileName(TestSerializeMethodName, c_JSON));
    // - берём результаты от ПРЕДЫДУЩИХ тестов, НЕКОШЕРНО с точки зрения TDD
    // НО! Чертовски эффективно.
    l_FileName := TestResultsFileName;
    l_Diagramms.SaveTo(l_FileName);
    CheckFileWithEtalon(l_FileName);
  finally
    l_Diagramms := nil;
  end; // try..finally
end;

end.

Класс для теста сохранения в *.png выглядит так:

unit TestSaveToPNG;

interface

uses
  TestFrameWork,
  msShapeTest,
  msInterfaces;

type
  TTestSaveToPNG = class(TmsShapeTestPrim)
  protected
    function MakeFileName(const aTestName: string; const aTestFolder: string): String; override;
    function TestResultsFileName: String; override;
    procedure SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm); override;
  published
    procedure CreateDiagrammWithShapeAndSaveToPNG_AndCheck;
  end; // TTestSaveToPNG

implementation

uses
  SysUtils,
  System.Types,
  msRegisteredShapes,
  FMX.Graphics;

{ TTestSaveToPNG }

procedure TTestSaveToPNG.SaveDiagramm(const aFileName: String; const aDiagramm: ImsDiagramm);
begin
  aDiagramm.SaveToPng(aFileName);
end;

procedure TTestSaveToPNG.CreateDiagrammWithShapeAndSaveToPNG_AndCheck;
begin
  CreateDiagrammWithShapeAndSaveAndCheck;
end;

function TTestSaveToPNG.MakeFileName(const aTestName: string; const aTestFolder: string): String;
begin
  Result := inherited + '.png';
end;

function TTestSaveToPNG.TestResultsFileName: String;
const
  c_PNG = 'PNG';
begin
  Result := MakeFileName(Name, c_PNG + ComputerName + '');
end;

initialization

end.

Опять же, внимательный читатель, который работал/работает с DUnit, заметит, что нет регистрации классов тестирования. А значит, прикрути мы их сейчас к проекту, ничего не случится.

Введём новый класс, который будет собой представлять “набор тестов” или, как его назвала команда DUnit, TestSuite.

Вот она — «наша особая магия».

Мы унаследуем новый класс от TestSuite. При этом “сделаем” каждый класс уникальным.

unit msShapeTestSuite;

interface

uses
  TestFramework,
  msShape,
  msShapeTest;

type
  TmsParametrizedShapeTestSuite = class(TTestSuite)
  private
    constructor CreatePrim;
  protected
    class function TestClass: RmsShapeTest; virtual; abstract;
  public
    procedure AddTests(TestClass: TTestCaseClass); override;
    class function Create: ITest;
  end; // TmsParametrizedShapeTestSuite

  TmsShapesTest = class(TmsParametrizedShapeTestSuite)
  protected
    class function TestClass: RmsShapeTest; override;
  end; // TmsShapesTest

  TmsDiagrammsTest = class(TmsParametrizedShapeTestSuite)
  protected
    class function TestClass: RmsShapeTest; override;
  end; // TmsDiagrammsTest

  TmsDiagrammsToPNGTest = class(TmsParametrizedShapeTestSuite)
  protected
    class function TestClass: RmsShapeTest; override;
  end; // TmsDiagrammsTest

implementation

uses
  System.TypInfo,
  System.Rtti,
  SysUtils,
  TestSaveToPNG;

// TmsShapesTest

class function TmsShapesTest.TestClass: RmsShapeTest;
begin
  Result := TmsShapeTest;
end;

// TmsDiagrammsTest

class function TmsDiagrammsTest.TestClass: RmsShapeTest;
begin
  Result := TmsDiagrammTest;
end;

// TmsParametrizedShapeTestSuite

constructor TmsParametrizedShapeTestSuite.CreatePrim;
begin
  inherited Create(TestClass);
end;

class function TmsParametrizedShapeTestSuite.Create: ITest;
begin
  Result := CreatePrim;
end;

procedure TmsParametrizedShapeTestSuite.AddTests(TestClass: TTestCaseClass);
begin
  Assert(TestClass.InheritsFrom(TmsShapeTestPrim));

  RandSeed := 10;
  TmsShapeTestPrim.CheckShapes(
    procedure(aShapeClass: RmsShape)
    var
      l_Method: TRttiMethod;
      l_DiagrammName: String;
      l_Seed: Integer;
      l_ShapesCount: Integer;
    begin
      l_Seed := Random(High(l_Seed));
      l_DiagrammName := 'Диаграмма ' + IntToStr(Random(10));
      l_ShapesCount := Random(1000) + 1;
      for l_Method in TRttiContext.Create.GetType(TestClass).GetMethods do
        if (l_Method.Visibility = mvPublished) then
          AddTest(RmsShapeTest(TestClass).Create(TmsShapeTestContext.Create(l_Method.Name, l_Seed, l_DiagrammName, l_ShapesCount,
            aShapeClass)));
    end);
end;

{ TmsDiagrammsToPNGTest }

class function TmsDiagrammsToPNGTest.TestClass: RmsShapeTest;
begin
  Result := TTestSaveToPNG;
end;

initialization

// Вот где регистрация !!!
RegisterTest(TmsShapesTest.Create);
RegisterTest(TmsDiagrammsTest.Create);
RegisterTest(TmsDiagrammsToPNGTest.Create);

end.

Наибольшую ценность в объяснении требует лишь один метод. Разберем его по строчкам.

procedure TmsParametrizedShapeTestSuite.AddTests(TestClass: TTestCaseClass);
begin
  // Контракт
  Assert(TestClass.InheritsFrom(TmsShapeTestPrim));

  // Задаем Random
  RandSeed := 10;
  // Создаем тесты с учетом контекста тестирования
  TmsShapeTestPrim.CheckShapes(
    procedure(aShapeClass: RmsShape)
    var
      l_Method: TRttiMethod;
      l_DiagrammName: String;
      l_Seed: Integer;
      l_ShapesCount: Integer;
    begin
      // Создаем “уникальный” контекст! Важно!

      // Задаем Random
      l_Seed := Random(High(l_Seed));
      // Формируем уникальное имя для диаграммы
      l_DiagrammName := 'Диаграмма ' + IntToStr(Random(10));
      // Задаем погрешность количества фигур
      l_ShapesCount := Random(1000) + 1;
      // Применяем новый RTTI. Для решения нужных нам проблем (всё вот так просто :), ну и далее вызываем нужный нам тест, с нужными нам параметрами (контекстом))
      for l_Method in TRttiContext.Create.GetType(TestClass).GetMethods do
        if (l_Method.Visibility = mvPublished) then
          AddTest(RmsShapeTest(TestClass).Create(TmsShapeTestContext.Create(l_Method.Name, 
																			l_Seed, 
																			l_DiagrammName, 
																			l_ShapesCount, 
																			aShapeClass)));
    end);
end;

Спасибо всем кто дочитал, как всегда, замечания и комментарии — приветствуются.

Repository

Автор: instigator21

Источник