Автор: Иванов Петр ака Brodia@a
Специально для Королевства Delphi

Прошло некоторое время, клавиатура остыла после тестирования и писательства, можно продолжать.
Попробуем сделать так, что бы программа следила за тем, что бы она была запущена в единственном экземпляре. Пока мы не углубились в обсуждение деталей реализации, хотелось бы объяснить, для чего такое "суровое" требование единственности и неповторимости. Дело в том, что если пользователям удобнее использовать одновременно несколько копий одной и той же программы, то это верный признак того, что изначально был спроектирован неверный интерфейс, скорее всего больше подошел бы MDI. Это первое, второе - считается, что чаще всего запуск второй копии происходит по ошибке, когда приложение свернуто и его просто не видно.

Данная тема уже не раз поднималась на просторах Королевства, например, здесь или здесь. Огромное множество материала, на данную тематику, чьей то щедрой рукой, разбросано по интернету. Правда, все методы однотипные и сводятся к тому, что программа, при запуске, проверяет какой-нибудь признак, если он не обнаружен - то запускается, если же присутствует... В этом месте возможны самые различные реакции, от сообщений, с требованием ответа/нажатия кнопки, до коварнейших систем оповещения создателей (например, как у M$ XP :). Признаком может служить, либо проверка наличия определенного окна, либо отметка в конфигурационном файле/регистре, либо банальный файл, создаваемый при запуске приложения и удаляемый при выходе из него. Более сложные системы, профессионального уровня, обращаются за советом, "можно, или нельзя", к специализированным лицензионным серверам.
Мы пойдем другим путем, наверное, самым простым, будем проверять наличие определенного мьютекса, реакция же будет вежливая - просто активизация окна. Данный метод не нов. Определенно, он работоспособен, но не мешало бы создать тест, который бы нас убедил, что это так. И это еще одна рекомендация XtremeProgramming - не лениться и стараться тестировать как можно больше. Вообще, если бы программисты знали, как много ошибок может быть, в казалось бы, в надежном и простом коде: Откроем testMiniProg.dpr и в файле testAppl.pas создадим следующую процедуру:

Const
  StrFailedTest = 'failure test';
...
procedure TTestUnitAppl.TestFindPrevInstance;
var
  Test1, Test2: boolean;
  Temp: THandle; 
begin
  Temp := Mutex;
  Test1 := not FindPrevInstance('Test');
  Test2 := FindPrevInstance('Test');
  StopPrevInstance;
  Check(Test1 and Test2, strFailedTest);
  Mutex := Temp; 
end;

Сами функции располагаются в Appl.pas и выглядят так:

Var
  Mutex: THandle = 0;
...
function FindPrevInstance(Name: string): boolean;
var
  Temp: THandle;
begin
  Temp := CreateMutex(nil, False, PChar(Name));
  Result := (GetLastError = ERROR_ALREADY_EXISTS);
  if Result then
    CloseHandle(Temp)
  else
    Mutex := Temp;
end;

procedure StopPrevInstance;
begin
  if Mutex > 0 then
    CloseHandle(Mutex);
end;

Теперь посмотрим, как можно будет показать найденную первую копию. Вариантов 'поискать и показать форму', в интернете, огромная масса. Тестовая процедура и сама функция выглядят так:

Unit testAppl;
...
procedure TTestUnitAppl.TestShowPrevInstance;
begin
  Check(ShowPrevInstance('DUnit'), strFailedTest);
end;

unit Appl;
...
function ShowPrevInstance(Name: string): boolean;
var
  PrevInstance: HWND;
begin
  Result := False;
  PrevInstance := FindWindow('TApplication', PChar(Name));
  if PrevInstance <> 0 then
  begin
    if IsIconic(PrevInstance) then
      ShowWindow(PrevInstance, SW_RESTORE);
    SetForegroundWindow(PrevInstance);
    Result := True;
  end;
end;

Компилируем, запускаем, проверяем - все работает, как требуется. Следует отметить, что в данном случае, тестировалось только возвращаемое ShowPrevInstance значение, сам эффект 'показа' незаметен. По этому, что бы ни уподобляться тому сапожнику, который без сапог, внесем в testMiniProg.dpr изменения, добавим в секцию uses модуль Appl и следующий код:

program testMiniProg;

uses
  Appl in '..\SOURCE\Appl.pas', 
  Forms, TestFrameWork, GUITestRunner,
  testAppl in 'testAppl.pas',
  testUnit in 'testUnit.pas' {testForm};

{$R *.res}

begin
  if FindAndShowPrevInstance('DUnit') then
    Halt
  else
  try
    Application.Initialize;
    Application.Title := 'DUnit';
    GUITestRunner.RunRegisteredTests;
  finally
    StopPrevInstance;
  end;
end.

В модуль Appl.pas, поместим функцию FindAndShowPrevInstance, которая будет искать и активизировать предыдущую копию программы. Её тестирование проведем на функциональном уровне, так как технологическое тестирование, хоть и возможно, но реализовывать его будет обременительно. Впрочем, желающие могут попробовать, не забудьте только мне показать, очень интересно.

function FindAndShowPrevInstance(Name: string): boolean;
begin
  Result := FindPrevInstance(Name);
  if Result then
    ShowPrevInstance(Name);
end;

Компилируем, запускаем, пробуем запустить вторую копию - у меня всё, как и предполагалось. Ну что же, можем считать, что функциональные тесты данная функция прошла. Есть один момент, который нужно учитывать. Не очень удобно то, что 'DUnit', или какое-то другое, милое вашему сердцу заветное слово, приходится писать два раза. Мне, к сожалению, так и не удалось приравнять Application.Title ни константе, ни переменной. Все время возникала ошибка dcc32.exe, по-видимому, из-за того, что данное значение используется самим Delphi. Возможно изменение, в виде переноса проверки FindAndShowPrevInstance в секцию initialization модуля Appl.pas, StopPrevInstance в секцию finalization, а сам unit прописать в uses dpr вашей программы самым ПЕРВЫМ. В принципе, я обычно так и делаю, в данном же случае пример просто показательный, потому и несколько упрощенный. Не сомневаюсь, даже данный подход можно улучшить. Особенность передаваемого FindAndShowPrevInstance значения в том, что оно должно быть такое же, как и имя главной формы программы, в противном случае невозможно будет правильное выполнение StopPrevInstance. Конечно, проверка мьютекса будет выполнена, и 'лишнее' приложение буде закрыто, но активизации первой копии не произойдет. Если кого-то не устраивает такое положение дел, например, этот кто-то, всегда дает одно и тоже имя главному модулю своих программ, то всё можно поправить. Просто расширьте число предаваемых функции параметров - отдельно имя мьютекса, отдельно имя главного окна.

Как видите, с помощью довольно бесхитростных средств нам удалось избежать атаки клонов собственных программ. Посмотрим, что можно сделать дальше.

Способность сохранять в конфигурационном файле какие-нибудь значения, например, положение и размеры окна, так же была освещена в интернет очень широко. В RxLib, есть неплохой компонент, умеющий многое, я сам пользовался им когда-то. По этому не будем изобретать ничего нового, но просто воспользуемся уже известными приемами. Почему именно ini-файл, а не регистр, или не способ хранение свойств компонентов, так как это делает Delphi? Свои плюсы и минусы есть у всех подходов, но для наших целей вполне хватит возможностей ini-файла. Будем считать, что ini-файл располагается в директории вместе с программой и имеет такое же имя, но другое расширение, например "ini" :). Традиционно, свойства окна хранят в отдельной секции ini-файла, с уникальным, для данного приложения именем. Используем для этого имя формы. И так, тесты:

procedure TTestUnitAppl.TestGetIniFileName;
begin
  Check(ExtractFileName(GetIniFileName) = 'testMiniProg' + cfgFileExt,
    strFailedTest);
end;

procedure TTestUnitAppl.TestGetSectionName;
begin
  Check(GetSectionName(Screen.Forms[0]) = 'GUITestRunner', strFailedTest);
end;

Сами же функции очень просты. В принципе, GetSectionName можно было бы расширить, включив возможность генерации имени секции для любого компонента, с учетом формы-владельца, но пока не будем этого делать:

Const
  cfgFileExt = '.ini';
...
function GetIniFileName: string;
begin
  Result := ChangeFileExt(Application.ExeName, cfgFileExt);
end;

function GetSectionName(Component: TComponent): string;
begin
  Result := Component.Name;
end;

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

1) отказа от восстановления параметров окна и установка значений по умолчанию,
2) изменение этих параметров в соответствии с изменением используемого шрифта.

Мне, больше по душе метод 'нумбер 2'. Что нужно сделать? вроде бы совсем не многое - всегда хранить размеры окна приведенными в соответствие с PPI времени создания, и при восстановлении проводить коррекцию, в соответствии с PPI времени выполнения. Положение левого верхнего угла формы изменять не следует, этого не делает Delphi, не будем делать и мы. В первой части статьи, говорилось, что величина масштабирования размеров окна зависит от отношения PPI's времен создания и выполнения, и такого понимания, тогда, было достаточно. Настало время все уточнить. На самом деле все обстоит несколько сложнее. Отношение PPI's используется для масштабирования высоты шрифта, после этого вычисляется высота образцового текста (у Delphi это строка '0' :). Ну а далее, для масштабирования, используется отношение старой и новой высот текста. Это отношение будет равно отношению PPI's в случае использования стандартных, для Windows, установок 'Крупный/Мелкий шрифт'. Размеры обычных экранных шрифтов строго фиксированы, по этому, использование нестандартных значений PPI' s может приводить к возникновению неприятных эффектов. В таких случаях, иногда, способен помочь шрифт TTF, например, как предлагается здесь. Следует отметить еще одну особенность масштабирования форм: непосредственно изменяются не сами размеры формы, а размеры клиентской части.

Вооружившись этими знаниями можно придти к выводу, что придется вносить изменения в функцию RtmPPI и DsgnPPI, и вычислять их результат иначе, чем было сделано ранее. Идея проста, использовать для масштабирования высоту текста, времени создания формы и времени выполнения приложения. Судя по всему - это более корректный способ, однако, в названиях переменных и процедур сохранена аббревиатура PPI. Остается вопрос, где, во время исполнения, взять высоту текста времени создания, ведь при создании окна все размеры изменяются. В принципе, все интересующие нас числа хранятся в ресурсах программы и можно попробовать прочитать их оттуда. Но, все попытки обратиться к ресурсам формы в программе, использую стандартные и рекомендованные для этого средства, ни к чему не привели. Точнее, нужные ресурсы программы успешно читаются, но уже в измененном виде, так уж устроен метод TCustomForm.ReadState :(. По этому, попытаемся прочитать данные из ресурса, так же, как это делает Delphi, но в сильно упрощенном варианте. Если вы загляните в исходный код VCL и просмотрите всё, что хоть как-то касается загрузки ресурсов программы, то поймете, зачем эти упрощения. Сведений, в литературе и интернете, связанных с вопросами чтения ресурсов во время исполнения программы, без создания самих компонентов, очень мало. К моему сожалению, практически, я ничего не нашел, и если кто-то знает, где есть подобного рода информация - поделитесь ссылкой. Текст функции, которая читает ресурсы определенной формы, выглядит так:

unit Appl;
...
function ReadFormRes(ResName: string; List: TStringList): boolean;
var
  Prop, Value: string;
  Stream: TResourceStream;
  Reader: TReader;
  HRsrc: THandle;
begin
  List.Clear;
  HRsrc := FindResource(HInstance, PChar(ResName), RT_RCDATA);
  Result := HRsrc <> 0;
  if not Result then Exit;
  Stream := TResourceStream.Create(HInstance, ResName, RT_RCDATA);
  Reader := TReader.Create(Stream, 4096);
  try
    Reader.ReadSignature;
    Reader.ReadStr;
    Reader.ReadStr;
    while not Reader.EndOfList do
    begin
      Prop := Reader.ReadStr;
      Value := strNil;
      case Reader.NextValue of
        vaInt8, vaInt16, vaInt32:
          Value := IntToStr(Reader.ReadInteger);
        vaString:
          Value := Reader.ReadString;
        else
          Reader.SkipValue;
      end;
      if Value <> strNil then
        List.Add(Format('%s = %s',[Prop,Value]));
    end;
    Reader.CheckValue(vaNull);
  finally
    Reader.Free;
    Stream.Free;
  end;
end;

Как я уже говорил, здесь представлен упрощенный вариант, который ищет определенный ресурс в программе, и сообщает в результате найден он или нет, а так же заполняет List набором строк найденных свойств и их значений. В список записываются не все свойства, а только те, которые определены в ресурсе и имеют тип, либо целого числа, либо строки, и принадлежат самой форме. При желании, можно организовать рекурсивный обход всех компонентов окна и чтение их свойств. Полный тест для данной функции не приводится, по той простой причине, что он довольно велик и явно выходит за рамки данной статьи. Может быть в другой статье :). Скажу лишь что, при построении такого рода функции, вряд ли стоит эмулировать полностью весь процесс загрузки ресурсов программы. В нашем случае, необходимо прочитать лишь некоторые свойства окна, что мы и сделаем. Конечно, можно поступить и так; создать пустую форму, у которой будет известна высота текста времени создания, но во время выполнения программы нам будет известно её масштабированное значение, что, собственно говоря, и нужно. Но, лично мне такой путь не нравиться, как по стилю решения проблемы, так и по тому, что при таком подходе возможна проблема с Constraints. Тестирующая функция довольно проста, хотя, конечно же, при тестировании полного варианта она выглядит иначе:

Procedure TtestUnitAppl.TestReadFormRes;
var
  List: TStringList;
  Test: boolean;
begin
  List := TStringList.Create;
  try
    ReadFormRes('TGUITestRunner', List);
    Test := List.Values['Caption'] = 'DUnit: An Xtreme testing framework';
  finally
    List.Free;
    Check(Test, strFailedTest);
  end;
end;

Изменим функцию RtmPPI таким образом, что бы она вычисляла, во время выполнения программы, высоту текста, для определенного нами окна. Соответственно DsgnPPI, изменится так, что вычисление её результата будет происходить с использованием ReadFormRes. Дополнительно, что бы избежать ошибок при определении RtmPPI, в ситуации, когда окно еще не создано, нам понадобится функция, которая по имени окна будет искать его в списке созданных форм и возвращать указатель на найденную форму, иначе nil.

Unit testAppl;
...
procedure TTestUnitAppl.TestFindForm;
var
  Test1, Test2, Test3: boolean;
begin
  Test1 := FindForm('testForm') = nil;
  testForm := TtestForm.Create(Application);
  try
    Test2 := FindForm('testForm') <> nil;
  finally
    testForm.Free;
    Test3 := FindForm('testForm') = nil;
  end;
  Check(Test1 and Test2 and Test3, strFailedTest);
end;

unit Appl;
...
function FindForm(FormName: string): TCustomForm;
var
  I: integer;
begin
  Result := nil;
  for I := 0 to Screen.FormCount - 1 do
    if Screen.Forms[I].Name = FormName then
    begin
      Result := Screen.Forms[I];
      Break;
    end;
end;

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

unit Appl;
...
const
  strDelphiMagicText = '0';
  strResTextHeight = 'TextHeight';
...
function RtmPPI(FormName: string): integer;
var
  Form: TCustomForm;
begin
  Result := 0;
  Form := FindForm(FormName);
  if Form <> nil then
    Result := Form.Canvas.TextHeight(strDelphiMagicText);
end;

function DsgnPPI(FormName: string): integer;
var
  List: TStringList;
  Form: TCustomForm;
begin
  List := TStringList.Create;
  try
    Form := FindForm(FormName);
    if Form <> nil then
    begin
      ReadFormRes(Form.ClassName, List);
      Result := StrToInt(List.Values[strResTextHeight]);
    end;
  finally
    List.Free;
  end;
end;

Эти функции проверяют наличие определенного окна . Если значение не равно nil, то считается, что форма уже создана, и у неё можно определить PPI's. Если форма еще не создана, то возвращается 0. В случае успешного выполнения функции, результатом будет значение высоты текста, отличное от 0. Так как сами функции несколько усложнились, то необходимо расширить их тестирование. Изменится так же, процедура TestDsgnVsRtmPPI, но функциональность её сохраниться, и даже несколько расшириться. Функция IsChangePPI удалена, из-за её несоответствия текущему моменту.

const
  testPPI = 16;
...
procedure TTestUnitAppl.TestRtmPPI;
var
  Test: boolean;
begin
  testForm := TtestForm.Create(Application);
  try
    Test := RtmPPI('testForm') = testForm.Canvas.TextHeight(strDelphiMagicText);
  finally
    testForm.Free;
    Check(Test, strFailedTest);
  end;
end;

procedure TTestUnitAppl.TestDsgnPPI;
var
  OldPPI, PPI: integer;
begin
  testForm := TtestForm.Create(Application);
  try
    OldPPI := DsgnPPI('testForm');
  finally
    testForm.Free;
    Check(OldPPI = testPPI, Format('DsgnPPI=%d, not %d', [OldPPI, testPPI]));
  end;
end;

procedure TTestUnitAppl.TestDsgnVsRtmPPI;
var
  Test: boolean;
  Text: string;
  OldPPI, NewPPI: integer;
begin
  Test := False;
  Text := strFailedTest;
  testForm := TtestForm.Create(Application);
  try
    OldPPI := RtmPPI('testForm');
    NewPPI := DsgnPPI('testForm');
    if (OldPPI > 0) and (NewPPI > 0) then
    begin
      Test := OldPPI = NewPPI;
      if not Test then
        Text := Format('DsgnPPI=%d not equal RtmPPI=%d DPI', [OldPPI, NewPPI]);
    end;
  finally
    testForm.Free;
    Check(Test, Text);
  end;
end;

Вроде бы все подготовительные действия выполнены, можно попытаться сохранить/восстановить состояние формы. Текст тестовой функции TestSaveLoadFormState можно посмотреть в testAppl.pas. Логика проверки следующая, создается окно, с некоторой задержкой демонстрируется, запоминается состояние окна в локальной переменной и сохраняется в ini-файле. Устанавливаются другие значения состояния окна, перемещается, сворачивается в левый нижний угол, выжидается некоторое время. Восстанавливается состояние окна, сохраненное в ini-файле. Дополнительно, проводится проверка значений состояния окна, до и после сохранения/восстановления. Если же вас не убедят результаты тестов, то всегда можно будет заглянуть в файл ini и посмотреть всё своими глазами. Сами процедуры сохранения/восстановления, и все процедуры к которым они обращаются, приведены поименно ниже:

...
procedure WriteIniShowCmd;
procedure ReadIniShowCmd;
procedure WriteIniFlags;
procedure ReadIniFlags;
procedure WriteIniWidth;
procedure ReadIniWidth;
procedure WriteIniHeight;
procedure ReadIniHeight;
procedure WriteIniLeft;
procedure ReadIniLeft;
procedure WriteIniTop;
procedure ReadIniTop;
procedure ScaleFormConstraints;
procedure SaveFormState;
procedure LoadFormState;
...

Полный текст процедур довольно велик по своим размерам, по этому здесь не приводится, но его можно посмотреть в Appl.pas, тестовые процедуры в testAppl.pas. Следует отметить, что при загрузке положения формы выполняется ScaleFormConstraints, которая корректирует значения Constraints окна, но другие элементы формы остаются без изменения. Желающие могут расширить её по своему усмотрению.

Те, кто смотрел исходники MiniProg1, заметят, что в исходных файлах MiniProg2 проведены некоторые 'косметические' изменения.

Продолжение следует ...

Declaimer aka Отмазка.

Я надеюсь, что люди, привыкшие читать академические труды, или слушать классические оперы, не станут осуждать автора, за его простую и незатейливую песнь кочевника. Что делал - о том и пел.
Исходную партитуру и ноты можно взять здесь: MiniProg2.zip (43K).

Любые претензии и предложения принимаются в обсуждение и/или мылом.
Предложения будут рассмотрены, претензии - проигнорированы.
С особым вниманием будут рассмотрены уточнения списка требований и новые тесты.

Все копирайты, если они известны, указаны. Иначе, автор не известен или копирайт утерян.