nlve/tests/lfmcheck/lfmcheck.lpr

{
  Проверка того, что свойства, записанные в файле формы, у наших
  элементов действительно есть.

  Зачем отдельно. Файл формы разбирается при запуске, а не при сборке:
  опечатка в имени свойства или в значении перечисления даёт не ошибку
  компиляции, а падение окна на старте. Здесь то же самое проверяется без
  окна — по сведениям о типах.
}
program lfmcheck;

{$mode objfpc}{$H+}

uses
  { Interfaces нужен, чтобы связалась вся LCL и заработала загрузка
    файлов форм. }
  Interfaces, Forms, Classes, SysUtils, Math, TypInfo, uTheme,
  uMediaProbe, uProject, uTransform, uTimelineCtrl,
  uPanCropForm, uDepsForm, uMismatchForm, uProgressForm, uProjectInfoForm,
  uRemuxForm;

var
  Failed: Integer = 0;

procedure CheckProp(AClass: TClass; const AName: string);
begin
  if GetPropInfo(AClass, AName) <> nil then
    WriteLn('  ok   ', AClass.ClassName, '.', AName)
  else
  begin
    WriteLn('  ПЛОХО ', AClass.ClassName, '.', AName, ' — свойства нет');
    Inc(Failed);
  end;
end;

procedure CheckEnum(ATypeInfo: PTypeInfo; const AName: string);
begin
  if GetEnumValue(ATypeInfo, AName) >= 0 then
    WriteLn('  ok   значение ', AName)
  else
  begin
    WriteLn('  ПЛОХО значение ', AName, ' — такого нет');
    Inc(Failed);
  end;
end;

{ Создаёт окно и тут же убирает.

  Смысл в самом создании: файл формы разбирается именно тогда. Элемент,
  который есть в файле формы и которого нет в классе, или обработчик с
  опечаткой в имени — всё это здесь и вскрывается, а иначе вскрылось бы у
  человека при открытии окна.

  Главное окно не проверяется: оно при создании читает настройки, строит
  меню и заводит плеер — это уже не проверка формы, а запуск программы. }
procedure CheckForm(AClass: TFormClass);
var
  F: TForm;
begin
  try
    F := AClass.Create(nil);
    try
      WriteLn('  ok   ', AClass.ClassName, ' — форма загружена');
    finally
      F.Free;
    end;
  except
    on E: Exception do
    begin
      WriteLn('  ПЛОХО ', AClass.ClassName, ': ', E.Message);
      Inc(Failed);
    end;
  end;
end;

procedure CheckTrue(const AName: string; AValue: Boolean);
begin
  if AValue then
    WriteLn('  ok   ', AName)
  else
  begin
    WriteLn('  ПЛОХО ', AName);
    Inc(Failed);
  end;
end;

{ Прилипание курсора воспроизведения к границам клипов.

  Проверяется числами, а не мышью: расчёт открыт наружу именно ради
  этого. Мышью пришлось бы поднимать окно, а окно в проверках — это уже
  не проверка расчёта, а проверка окружения. }
procedure CheckPlayheadSnap;
var
  Proj: TProject;
  Info: TMediaInfo;
  Media: TMediaItem;
  Timeline: TTimelineControl;
begin
  WriteLn;
  WriteLn('Прилипание курсора к границам клипов');
  WriteLn;

  Info := Default(TMediaInfo);
  Info.Valid := True;
  Info.Kind := mkVideo;
  Info.Duration := 600;
  Info.HasVideo := True;
  Info.VideoCodec := 'hevc';
  Info.Width := 1920;
  Info.Height := 1080;
  Info.FpsNum := 30;
  Info.FpsDen := 1;
  Info.PixFmt := 'yuv420p';

  Proj := TProject.Create;
  Timeline := TTimelineControl.Create(nil);
  try
    Proj.Clear;
    Proj.AddTrack('V1');
    Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
    { Два куска встык: границы на 0, 1.5 и 3. }
    Proj.AddClip(Proj.Tracks[0], Media, 0, 1.5, 0);
    Proj.AddClip(Proj.Tracks[0], Media, 10, 1.5, 1.5);

    Timeline.Project := Proj;
    { Сто точек в секунду: порог прилипания в восемь точек — это 0.08 с. }
    Timeline.PixelsPerSecond := 100;
    Timeline.PlayheadSnap := True;

    CheckTrue('стык рядом — притянуло',
      Abs(Timeline.SnapPlayhead(1.53) - 1.5) < 0.0001);
    CheckTrue('с другой стороны — тоже',
      Abs(Timeline.SnapPlayhead(1.47) - 1.5) < 0.0001);
    CheckTrue('далеко от границ — не тронуло',
      Abs(Timeline.SnapPlayhead(0.7) - 0.7) < 0.0001);
    CheckTrue('начало монтажа притягивает',
      Abs(Timeline.SnapPlayhead(0.05)) < 0.0001);
    CheckTrue('конец последнего клипа притягивает',
      Abs(Timeline.SnapPlayhead(2.96) - 3) < 0.0001);

    { На мелком масштабе порог в точках даёт больший запас по времени. }
    Timeline.PixelsPerSecond := 10;
    CheckTrue('масштаб мельче — притягивает дальше',
      Abs(Timeline.SnapPlayhead(1.7) - 1.5) < 0.0001);

    Timeline.PixelsPerSecond := 100;
    Timeline.PlayheadSnap := False;
    CheckTrue('выключено — не притягивает',
      Abs(Timeline.SnapPlayhead(1.53) - 1.53) < 0.0001);
  finally
    Timeline.Free;
    Proj.Free;
  end;
end;

{ Рез не должен терять настройки клипа.

  Половина клипа после реза — тот же клип, и цветовой ключ, кадрирование,
  прозрачность, громкость и текст должны остаться при обеих половинах.
  Однажды не остались: у хвоста пропадал ключ, клип переставал быть
  наложением и закрывал собой всё, что под ним. }
procedure CheckSplitKeepsSettings;
var
  Proj: TProject;
  Info: TMediaInfo;
  Media: TMediaItem;
  Timeline: TTimelineControl;
  Head, Tail, Cl: TClip;
  Key: TColorKey;
  Tr: TMediaTransform;
  I: Integer;
begin
  WriteLn;
  WriteLn('Рез сохраняет настройки клипа');
  WriteLn;

  Info := Default(TMediaInfo);
  Info.Valid := True;
  Info.Kind := mkVideo;
  Info.Duration := 600;
  Info.HasVideo := True;
  Info.VideoCodec := 'hevc';
  Info.Width := 1920;
  Info.Height := 1080;
  Info.FpsNum := 30;
  Info.FpsDen := 1;
  Info.PixFmt := 'yuv420p';

  Proj := TProject.Create;
  Timeline := TTimelineControl.Create(nil);
  try
    Proj.Clear;
    Proj.AddTrack('V1');
    Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
    Cl := Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 0);

    Key := DefaultColorKey;
    Key.Enabled := True;
    Key.Similarity := 22;
    Cl.ColorKey := Key;
    Cl.Opacity := 0.5;
    Cl.Volume := 0.3;
    Tr := Cl.Transform;
    Tr.Zoom := 0.4;
    Tr.OffsetX := 0.7;
    Cl.Transform := Tr;
    Cl.GroupId := 'g1';

    Timeline.Project := Proj;
    Timeline.PixelsPerSecond := 100;
    Timeline.Playhead := 4;
    Timeline.SplitAtPlayhead(False, False);

    CheckTrue('клипов стало два', Proj.Tracks[0].Count = 2);
    if Proj.Tracks[0].Count <> 2 then
      Exit;

    Head := nil;
    Tail := nil;
    for I := 0 to Proj.Tracks[0].Count - 1 do
      if Proj.Tracks[0][I].TlStart < 0.001 then
        Head := Proj.Tracks[0][I]
      else
        Tail := Proj.Tracks[0][I];
    CheckTrue('обе половины нашлись', (Head <> nil) and (Tail <> nil));
    if (Head = nil) or (Tail = nil) then
      Exit;

    CheckTrue('ключ остался у хвоста', Tail.ColorKey.Enabled);
    CheckTrue('и с тем же цветом', Tail.ColorKey.Color = Key.Color);
    CheckTrue('и с тем же допуском', Tail.ColorKey.Similarity = 22);
    CheckTrue('прозрачность осталась', Abs(Tail.Opacity - 0.5) < 0.001);
    CheckTrue('громкость осталась', Abs(Tail.Volume - 0.3) < 0.001);
    CheckTrue('кадрирование осталось',
      (Abs(Tail.Transform.Zoom - 0.4) < 0.001) and
      (Abs(Tail.Transform.OffsetX - 0.7) < 0.001));
    CheckTrue('ключ остался и у головы', Head.ColorKey.Enabled);
    { Связки разные, и обе не пустые: иначе удаление одной половины
      уносило бы вторую. }
    CheckTrue('связка у половин разная и не пустая',
      (Head.GroupId <> Tail.GroupId) and (Head.GroupId <> '') and
      (Tail.GroupId <> ''));
    CheckTrue('появление у хвоста снято', Abs(Tail.FadeIn) < 0.001);
  finally
    Timeline.Free;
    Proj.Free;
  end;
end;

begin
  WriteLn('Свойства из файлов форм');
  WriteLn;

  CheckProp(TThemedButton, 'Icon');
  CheckProp(TThemedButton, 'Down');
  CheckProp(TThemedButton, 'Arrow');
  CheckProp(TThemedButton, 'Caption');
  CheckProp(TThemedButton, 'ShowHint');

  CheckEnum(TypeInfo(TThemedIcon), 'tiSnap');
  CheckEnum(TypeInfo(TThemedIcon), 'tiRipple');
  CheckEnum(TypeInfo(TThemedIcon), 'tiLog');
  CheckEnum(TypeInfo(TThemedIcon), 'tiNone');

  WriteLn;
  WriteLn('Загрузка файлов форм');
  WriteLn;
  Application.Initialize;
  CheckForm(TPanCropForm);
  CheckForm(TDepsForm);
  CheckForm(TMismatchForm);
  CheckForm(TProgressForm);
  CheckForm(TProjectInfoForm);
  CheckForm(TRemuxForm);

  CheckPlayheadSnap;
  CheckSplitKeepsSettings;

  WriteLn;
  if Failed = 0 then
    WriteLn('ВЕРДИКТ: все проверки пройдены')
  else
  begin
    WriteLn('ВЕРДИКТ: не пройдено проверок: ', Failed);
    Halt(1);
  end;
end.