Предотвращение запуска второй копии программы

[Nik]

Если не устраивает привязка компонента к LCL, из него можно выковырять значимый код -- создание SimpleIPC сервера и подключение к нему.

Там даже выколупывать ничего не нужно. Можно просто использовать TUniqueInstance без привязки к форме (см. пример - если там убрать ссылки на LCL и отключить формы - всё прекрасно работает).

Ссылка на закачку компонента битая
UniqueInstance https://svn.bountysource.com/luipack/trunk/uniqueinstance/

Ссылку в wiki исправил.

[dunin]

...Можно просто использовать TUniqueInstance...

Это как-то соотносится с Виндусовским Mutex? Или это совсем из другой оперы?
Почему спрашиваю: есть замечательный инсталлятор InnoSetup и в нем есть функция проверки Mutex. Т.е. если создать одноименный mutex в программе, то инсталляшка сообщит, что программа уже запущена и не позволит продолжить установку при(поверх) запущенной программе. Очень хотелось бы иметь кросполатформенное решение и при этом не отказываться от проверенных инсталляционных пакетов.

[coyot.rush]

Это как-то соотносится с Виндусовским Mutex? Или это совсем из другой оперы?

Фрагмент SimpleIPC под Windows

Код: Выделить всё

function TWinMsgClientComm.ServerRunning: Boolean;
begin
  Result:=FindWindow(MsgWndClassName,PChar(FWindowName))<>0;
end;

Напоминает старый антиотладочный приём

Odyssey 13.01.2011 23:24:52
С сокетами идея интересная -- задач с ней можно решить побольше, но она и потруднее, и возможно потребует сторонних библиотек.

1) Ни каких сторонних библиотек не под Windows, не под Linux не надо (libc и kernel32.dll)

Не понимаю, зачем изобретать велосипед. UniqueInstance использует уже имеющийся в FPC кроссплатформенный механизм взаимодействия процессов -- SimpleIPC. Если не устраивает привязка компонента к LCL, из него можно выковырять значимый код -- создание SimpleIPC сервера и подключение к нему. Никаких платформозависимых решений, никаких временных файлов.

2)Имхо, под Windows код нужно исправлять и заменить на Named Pipes
3)

никаких временных файлов

Unix

Код: Выделить всё

procedure TPipeServerComm.StartServer;
begin
  If not FileExists(FFileName) then
    If (fpmkFifo(FFileName,438)<>0) then
      Owner.DoError(SErrFailedToCreatePipe,[FFileName]);
  FStream:=TFileStream.Create(FFileName,fmOpenReadWrite);
end;

[dunin]

Код: Выделить всё

function TWinMsgClientComm.ServerRunning: Boolean;
begin
  Result:=FindWindow(MsgWndClassName,PChar(FWindowName))<>0;
end;

Облом с мютексами...

[Odyssey]

Фрагмент SimpleIPC под Windows

Код: Выделить всё

...
Result:=FindWindow(MsgWndClassName,PChar(FWindowName))<>0;
...

Напоминает старый антиотладочный приём

Был такой, на поиск окна IDE, ЕМНИП Серьёзных недостатков в этом коде не вижу, кроме неприятных воспоминаний.

Odyssey 13.01.2011 23:24:52
С сокетами идея интересная -- задач с ней можно решить побольше, но она и потруднее, и возможно потребует сторонних библиотек.

1) Ни каких сторонних библиотек не под Windows, не под Linux не надо (libc и kernel32.dll)

Я имел в виду FPC-библиотеки, типа Synapse. Можно, конечно, всё сделать на голом Sockets, или даже написать свою кроссплатформенную обёртку сокетов, но это время.

2)Имхо, под Windows код нужно исправлять и заменить на Named Pipes

Возможно, я не делал сравнения скорости/надёжности Named Pipes и Window Messages. Думаю у разработчиков FPC были свои причины выбрать то, что они выбрали. И если им предложить патч для работы SimpleIPC через Named Pipes с обоснованиями и результатами бенчмарков, возможно даже они его примут. Вопрос в другом: использовать ли в своей программе готовый высокоуровневый класс, входящий в FCL, протестированный и кроссплатформенный, или делать своё низкоуровневое решение для каждой платформы отдельно.

3)

никаких временных файлов

Unix
...

А под Windows будет уже другой код, который ещё нужно написать. А потом ещё сделать кроссплатформенную обёртку. В то время как в SimpleIPC это уже есть.

[coyot.rush]

Юнит для предотвращения запуска второй копии программы и передачи параметров. Код немного не "причесан" и не доделан , но работает

Код: Выделить всё

{
    UsendParam Copyright (c) 2011 by Coyot.RusH

    version   08/02/2011

    This unit is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}

unit usendparam;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils{$ifdef windows},Windows{$endif}{$ifdef linux},libc{$endif};


  type
  TOnMessageEvent = procedure (const Sender:TObject;const Msg:string ) of object;
  TOnErrorEvent =procedure (const Sender:TObject;const Error:integer ) of object;
 
  type 
  infoParamLine=record
  Count:integer;
  Tail:integer;
  end;
 
  type

  { TSendParam }

  TSendParam=class(TThread)
  private
  FOnError: TOnErrorEvent;
  FOnMessage:TOnMessageEvent;
  FIDServer:string;
  FMode:Boolean;

  SError:integer;
  SMessage:String;
  {$ifdef windows}
  hpipe:Thandle;
  FPipe: PHANDLE;
  pSD: PSECURITY_DESCRIPTOR;
  sa: SECURITY_ATTRIBUTES;
  FOverLapWrt: OVERLAPPED;
  FEventWrt: THANDLE;
  {$endif}
  {$ifdef linux}
  hpipe:integer;
  {$endif}
  function GetCommandLine():string;
  function GetCountNumberCommandLine(const Str:string):infoParamLine;
  function CheckRunningServer():Boolean;
  function RunServer():Boolean;
  function RunClient():Boolean;
  function WriteMessage(Msg:String):integer;

  procedure DoError(const Error:integer);
  procedure DoMessage(const Msg:string);
  procedure CallError();
  procedure CallMessage();
  public
  constructor Create(const AppId:string);
  destructor Destroy; override;
  procedure Execute; override;
  property CheckTwoApp: Boolean read FMode;
  property OnMessage:TOnMessageEvent read FOnMessage write FOnMessage;
  property OnError:TOnErrorEvent read FOnError write FOnError;
  property ParamLine:string read GetCommandLine;
  end;

function DecodeError(const Error:integer):string;

implementation
uses main;
const
  FailedToRunningServer=0;
  FailedToRunningClient=1;
  FailedToPreviousRun=2;
  FailedToAllocationMemoryForSD=3;
  FailedToInitializeSecurityDescriptor=4;
  FailedToSetSecurityDescriptor=5;
  CannotFindPipe=6;//Assure Server32 is started, check share name.
  FailedToCreateFile=7;
  FailedToCreateNamedPipe=8;
  FailedToReadFile=9;
   
   
  Block_Size=10;
  {$ifdef windows}   
  MAX_PIPE_INSTANCES = 100;
  NAME_SIZE = 25;
  LINE_LEN = 80;
  IN_BUF_SIZE = Block_Size;
  OUT_BUF_SIZE = Block_Size;
  TIME_OUT = 0;
  MAX_READ = Block_Size*Sizeof(Char);
  MAX_WRITE =Block_Size*sizeof(Char);
  {$endif}
  CR=#13;

function DecodeError(const Error: integer): string;
begin
case Error of
  FailedToRunningServer:Result:='Failed To Running Server';
  FailedToRunningClient:Result:='Failed To Running Client';
  FailedToPreviousRun:Result:='Failed To Previous Run';
  FailedToAllocationMemoryForSD:Result:='Failed To Allocation Memory For Security Descriptor';
  FailedToInitializeSecurityDescriptor:Result:='Failed To Initialize Security Descriptor';
  FailedToSetSecurityDescriptor:Result:='Failed To Set Security Descriptor';
  CannotFindPipe:Result:='Cannot Find Pipe: Assure Server32 is started, check share name';
  FailedToCreateFile:Result:='Failed To Create File';
  FailedToCreateNamedPipe:Result:='Failed To Create Named Pipe';
  FailedToReadFile:Result:='Failed To Read File';
else;
Result:='Unknown Error';
end;
end;


{ TSendParam }

procedure TSendParam.DoError(const Error: integer);
begin
if Assigned(OnError) then
begin
  SError:=Error;
  Synchronize(@CallError);
end;
end;

procedure TSendParam.DoMessage(const Msg: string);
begin
if Assigned(OnMessage) then
begin
  SMessage:=Msg;
  Synchronize(@CallMessage); 
end;
end;

procedure TSendParam.CallError();
begin
FOnError(self,SError);
end;

procedure TSendParam.CallMessage();
begin
FOnMessage(self,SMessage);
end;


function TSendParam.GetCommandLine: string;
var
Iparam:integer;
tmpS:string;
begin
tmpS:='';
for iparam:=1 to Paramcount do
begin
   tmpS:=tmpS+ParamStr(iparam)+CR;
end;
Result:=tmpS{$ifdef linux}+CR{$endif};
end;





function TSendParam.CheckRunningServer(): Boolean;
{$IFDEF WINDOWS}
var
r:integer;
begin
Result := False;
r:=CreateFile(PChar(sysutils.GetEnvironmentVariable('USERPROFILE')+'\.'+FIDServer+'.lock'),
GENERIC_READ or GENERIC_WRITE,0,nil, CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL, 0);
if r=-1
then Result:=True;
end;
{$ENDIF}
{$IFDEF LINUX}
var
  FileHandle, Tvar: Integer;
  LockVar: TFlock;
  smode: Byte;
  FileAccessRights:integer;
begin
  Result :=False;
  FileAccessRights:=S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH;
  begin
    FileHandle := open(PChar(GetEnvironmentVariable('HOME')+'/.'+FIDServer+'.lock'),O_CREAT or O_TRUNC or O_RDWR, FileAccessRights);
    if FileHandle = -1 then  Exit;
    begin
      with LockVar do
      begin
        l_whence := SEEK_SET;
        l_start := 0;
        l_len := 0;
        l_type :=F_WRLCK ;
      end;
      Tvar :=  fcntl(FileHandle, F_SETLK, LockVar);
      if Tvar = -1 then
      begin
        Result:=True;
        __close(FileHandle);
        Exit;
      end;
    end;
    Result :=False;
  end;
end;
{$ENDIF}

function TSendParam.RunServer(): Boolean;
{$IFDEF WINDOWS}
var
tmpNamePipe:string;
begin
Result:=True;
pSD := PSECURITY_DESCRIPTOR(LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH));
   if not Assigned(pSD) then
   begin
    DoError(FailedToAllocationMemoryForSD);
    Result:=False;
    Exit;
   end;
   if not InitializeSecurityDescriptor (pSD,SECURITY_DESCRIPTOR_REVISION) then
   begin
    DoError(FailedToInitializeSecurityDescriptor);
    LocalFree(HLOCAL(pSD));
    Result:=False;
    Exit;
   end;
   if not SetSecurityDescriptorDacl(pSD, true, nil, false) then
   begin
    DoError(FailedToSetSecurityDescriptor);
    LocalFree(HLOCAL(pSD));
    Result:=False;
    Exit;
   end;
   sa.nLength := sizeof(sa);
   sa.lpSecurityDescriptor := pSD;
   sa.bInheritHandle := true;
tmpNamePipe:='\\.\PIPE\'+FIDServer;
hPipe := CreateNamedPipe (PChar(tmpNamePipe),
    PIPE_ACCESS_DUPLEX,
    PIPE_WAIT or
    PIPE_READMODE_MESSAGE or
    PIPE_TYPE_MESSAGE,
    MAX_PIPE_INSTANCES,
    OUT_BUF_SIZE*SizeOf(Char),
    IN_BUF_SIZE*SizeOf(char),
    TIME_OUT,
    @sa);
if hPipe = INVALID_HANDLE_VALUE then
    begin
    DoError(FailedToCreateNamedPipe);
    Result:=False;
    Exit;
    end;
end;
{$ENDIF}
{$ifdef linux}
var
Path:string;
const
a=0400;
begin
Result:=False;
Path:=GetEnvironmentVariable('HOME')  + '/.pipe.' + FIDServer;
if libc.mkfifo(PChar(Path), a) = 0 then
begin
  Result:=True;// Create Pipes
end;
hpipe :=libc.Open(Pchar(Path), O_RDWR);
if hpipe>-1 then Result:=True; 
end;
{$ENDIF}

function TSendParam.RunClient(): Boolean;
{$IFDEF WINDOWS}
var
tmpName:string;
retCode: DWORD;
begin
Result:=True;
New(FPipe);
tmpName:='\\.\PIPE\'+FIDServer;
if WaitNamedPipe(PChar(tmpName),2000) then
begin
FPipe^ := CreateFile (PChar(tmpName),
GENERIC_WRITE or
GENERIC_READ,
FILE_SHARE_READ or
FILE_SHARE_WRITE,
nil,
OPEN_EXISTING,
FILE_FLAG_OVERLAPPED,
0);

if FPipe^ = INVALID_HANDLE_VALUE then
begin
  retCode := GetLastError;
if (retCode = ERROR_SEEK_ON_DEVICE) or (retCode = ERROR_FILE_NOT_FOUND) then
  begin
  DoError(CannotFindPipe);
  Result:=False;
  end
else
begin
DoError(FailedToCreateFile);
Result:=False;
end;
Result:=False;
Exit;
end;
end;
end;
{$ENDIF}
{$ifdef linux}
var
Path:string;
begin
Result:=true;
Path:=GetEnvironmentVariable('HOME')  + '/.pipe.' + FIDServer;
hpipe:=Open(PChar(Path), O_RDWR);
if hpipe=-1 then Result:=False;
end;
{$ENDIF}

function TSendParam.WriteMessage(Msg: String): integer;
{$IFDEF WINDOWS}
var
rc: Boolean;
bytesWritten: DWORD;
lastError: DWORD;
hEventWRT: THANDLE;
begin
rc := WriteFile (FPipe^, MSg[1],Length(Msg), bytesWritten,@FOverLapWrt);
if not rc then
begin
  lastError := GetLastError;
  if lastError = ERROR_IO_PENDING then WaitForSingleObject (hEventWRT, INFINITE);
end;
DisconnectNamedPipe(FPipe^);
Result:=bytesWritten;
end;
{$ENDIF}
{$ifdef linux}
begin
Result:=libc.__write(hpipe,Msg[1] ,Length(Msg));
end;
{$ENDIF}







constructor TSendParam.Create(const AppId:string);
var
iL:integer;
iC:infoParamLine;
CL:string;
tmp:string;
begin
  inherited Create(True);
  FIDServer:=AppId;
  FMode:=False;
  FMode:=CheckRunningServer();
  if FMode=False then
  begin
  //If not running  Server
  end
  else
  begin
   //If Running Server
   if RunClient()=False then
   begin
    DoError(FailedToRunningClient);
   end
   else
   begin
    CL:=GetCommandLine;
    ic:=GetCountNumberCommandLine(CL);
    for iL:=0 to iC.count-1 do
     begin
     tmp:=Copy(CL,(iL*Block_Size)+1,Block_Size);
     if (iL=ic.count-1) and (ic.tail>0) then
      begin
       SetLength(tmp,ic.tail);
       WriteMessage(tmp);
      end
      else
      begin
       WriteMessage(Copy(CL,(iL*Block_Size)+1,Block_Size));
      end;
     end;   
   end;
  end;
end;

destructor TSendParam.Destroy;
begin
  //TODO Free procedure
  inherited Destroy;
end;




function TSendParam.GetCountNumberCommandLine(const Str:string):infoParamLine;
var
L,C,M:integer;
begin
L:=Length(Str);
C:=0;
C:=L div Block_Size;
M:=L mod Block_Size;
Result.tail:=M;
if M>0 then C:=c+1;
Result.Count:=c;
end;


procedure TSendParam.Execute;
{$IFDEF WINDOWS}
var
  Msg,tmp:string;
  bytesRead: DWORD;
  bytesTransRd: DWORD;
  rc: Boolean;
  LastError: DWORD;
  ExitLoop: Boolean;
  OverLapWrt: OVERLAPPED;
  OverLapRd: OVERLAPPED;
  hEventRd: THANDLE;
  CL:string;
begin
  tmp:='';
  if FMode=True then
  begin
  //Client
  end
  else
  begin
  //Server
   while not Terminated do
   begin
    SetLength(Msg,Block_Size);
    if RunServer=False then
    begin
     DoError(FailedToRunningServer);
     //Exit;
    end;
    ExitLoop := false;
    lastError := 0;
    ConnectNamedPipe(hPipe, nil);
    hEventRd := CreateEventW (nil, true, false, nil);
    FillChar(OverLapRd, sizeof(OVERLAPPED), 0);
    OverLapRd.hEvent := hEventRd;
    if not rc then
    lastError := GetLastError;
    if lastError = ERROR_IO_PENDING then
    WaitForSingleObject (hEventRd, INFINITE);
    repeat
   
    rc := ReadFile (hPipe, Msg[1], MAX_READ, bytesRead, @OverLapRd);
    if not rc then
    begin
     lastError := GetLastError;
     DoError(FailedToReadFile);
     case lastError of
      ERROR_IO_PENDING:
       begin
        WaitForSingleObject (hEventRd, INFINITE);
        end;
      ERROR_BROKEN_PIPE:
       begin
        ExitLoop := true;
       end;
     else
      begin
       DoError(FailedToReadFile);
       ExitLoop := true;
      end;
     end;
    end
    else
    begin
    if bytesRead<Block_Size then
     begin
      SetLength(Msg,bytesRead);     
     end;
    tmp:=tmp+Copy(Msg,1,bytesRead);
    end;
    if not ExitLoop then
    begin
      GetOverlappedResult (hPipe, OverLapRd, bytesTransRd, false);
    end;   
    until ExitLoop;
    DoMessage(tmp);
    tmp:='';
    CloseHandle (hPipe);
    CloseHandle (hEventRd);
    DisconnectNamedPipe (hPipe);   
   end;
end;
end;
{$ENDIF}
{$ifdef linux}
var
c:      char;
tmpstr: string;
begin
if FMode=False then
  begin
  //Server
  if RunServer=False then
   begin
    DoError(FailedToRunningServer);
    //Exit;
   end;
   while not Terminated do
   begin
    tmpstr     := '';
    repeat
    begin
     if libc.__read(hpipe, c, 1) > 0 then
     begin
      tmpstr := tmpstr + c;
     end;
    end;
    until c=Cr;
    DoMessage(tmpstr);
  end;
end;
end;
{$ENDIF}



end.


Пример

Код: Выделить всё

program pr_sendparam;

{$ifdef FPC}{$mode objfpc}{$h+}{$endif}

{$ifdef FPC}

{$ifdef mswindows}{$apptype gui}{$endif}

{$endif}

uses

{$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}msegui,mseforms,main,usendparam;


begin

cta:=TSendParam.Create('Pr_SendParam');

if cta.CheckTwoApp=False then

begin

application.createform(tmainfo,mainfo);

CTA.OnMessage:=@mainfo.OnGetParam;

CTA.OnError:=@mainfo.OnError;

application.run; 

end;



end.

Код: Выделить всё

unit main;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
mseglob,mseguiglob,mseguiintf,mseapplication,msestat,msemenus,msegui,
msegraphics,msegraphutils,mseevent,mseclasses,mseforms,msesimplewidgets,
msewidgets,msedataedits,mseedit,msestrings,msetypes,msesplitter,usendparam; 
type
tmainfo = class(tmainform)
   Mlog: tmemoedit;
   b_clear: tbutton;
   procedure _onclear(const sender: TObject);
   procedure OnGetParam(const Sender:TObject;const Msg:string );
   procedure OnError(const Sender:TObject;const Error:integer);
   procedure _oncreate(const sender: TObject);
end;
var
mainfo: tmainfo;
CTA:TSendParam;
implementation
uses
main_mfm;
procedure tmainfo._onclear(const sender: TObject);
begin
Mlog.text:='';
end;

procedure tmainfo.OnGetParam(const Sender: TObject; const Msg: string);
begin
mainfo.mlog.text:=mainfo.mlog.text+Msg;
end;

procedure tmainfo.OnError(const Sender: TObject;const Error: integer);
begin
mainfo.mlog.text:=mainfo.mlog.text+DecodeError(Error)+#13;
end;


[zub]

Ктонибудь юзает UniqueInstance? Приделал, в винде всё прекрасно работает, в линуксе нет(( - вторая копия видит первую, отправляет ей свою командную строку и закрывется. но в первой копии UniqueInstanceBase.FIPCServer.OnMessage почемуто несрабатывает при этом.

[*Rik*]

Ктонибудь юзает UniqueInstance? Приделал, в винде всё прекрасно работает, в линуксе нет(( - вторая копия видит первую, отправляет ей свою командную строку и закрывется. но в первой копии UniqueInstanceBase.FIPCServer.OnMessage почемуто несрабатывает при этом.

В линуксе надо принудительно проверку делать. Сам по себе OnMessage не сработает, надо вызывать PeekMessage.
Я делал так, это не связано с UniqueInstance, из проекта использующего TSimpleIPCServer, просто непрерывно крутил проверку в параллельном потоке:

Код: Выделить всё

type

  { TMessageHook }

  TMessageHook = class(TThread)
  private
    DebugServer: TSimpleIPCServer;
    procedure ApplyMessage;
  protected
    procedure Execute; override;
  public
    constructor Create(CreateSuspended: Boolean; ASrv: TSimpleIPCServer);
  end;

implementation

{ TMessageHook }

procedure TMessageHook.ApplyMessage;
begin
  DebugServer.PeekMessage(3, True);
end;

procedure TMessageHook.Execute;
begin
  while (not Terminated) and (true) do
  begin
    if DebugServer.Active then
    if DebugServer.PeekMessage(3, False) then
    begin
      Synchronize(@ApplyMessage);
    end;
  end;
end;

constructor TMessageHook.Create(CreateSuspended: Boolean;
  ASrv: TSimpleIPCServer);
begin
  inherited Create(CreateSuspended);
  DebugServer := ASrv;
end;\0


[zub]

Потоков у меня нет, всё в одном. Могу я обойтись onidle? что мне проверить у UniqueInstanceBase.FIPCServer чтоб самому вызвать OnMessage?
Извиняюсь за тупость, но первый раз сталкиваюсь с TSimpleIPCServer((

[*Rik*]

Потоков у меня нет, всё в одном. Могу я обойтись onidle? что мне проверить у UniqueInstanceBase.FIPCServer чтоб самому вызвать OnMessage?
Извиняюсь за тупость, но первый раз сталкиваюсь с TSimpleIPCServer((

Скачал компоненту, посмотрел исходник, там не так много букв.. Для Unix там тоже все предусмотрено, для юникс через {$ifdef} вставлены куски кода с PeekMessage, но работают они если назначен обработчик события на OnOtherInstance. В этот обработчик компонента валит все что пришло в сообщении.

[zub]

>>но работают они если назначен обработчик события на OnOtherInstance.
Я не использую компонент TUniqueInstance, только модуль UniqueInstanceBase.

>>там не так много букв..
Ок, разберусь

Добавлено спустя 7 часов 12 секунд:
Вроде решилось вставкой

Код: Выделить всё

{$ifdef linux}
UniqueInstanceBase.FIPCServer.PeekMessage(0,true);
{$endif}

в onidle

[dmadma]

А как быть когда программа завершилась аварийно?