(проблема с любыми предложениями типа "создать файлик/семафор/ещё какую хрень, и проверять по его наличию запущена ли программа" упираются в тот факт, что программа может и умереть, не успев подчистить за собой. И что тогда - больше не запустится?)
Вот. В виндовсе эксплуатируется тот факт, что система сама метит мьютекс как "бесхозный" если скончалась породившая его программа (и не важно, успела она перед смертью пискнуть, или нет). В Линуксе эксплуатируется тот факт, что для всех запущенных процессов в файловой системе имеются виртуальные папки "/proc/<номер PID>".
Вопрос знатокам: моя процедура создаёт маленький файлик, куда пишет PID. Дело это муторное и не надёжное, из-за того, что не ясно в какой папке его создавать. Там же, где лежит сама программа? А если это /bin/ или /usr/bin/ ? Точно ведь по рукам дадут. Так вот, вопрос: как в Линуксе создавать именованые мьютексы, или сходжие объекты, способные содержать число?
- Код: Выделить всё
unit cl_pms;
{$ifdef fpc}
{$mode delphi}
{$endif}
interface
uses
SysUtils {$ifdef win32}, Windows{$else}, baseunix {$endif};
function ThisIsAnOnlyInstance: boolean;
implementation
{$ifdef win32}
var
M: THandle;
Di: boolean = false;
function ThisIsAnOnlyInstance: boolean;
var N: string;
begin
Result:=True;
N:=ChangeFileExt(ExtractFileName(ParamStr(0)),'') + 'SingleInstanceMutex';
M:=OpenMutex(MUTEX_MODIFY_STATE, False, PChar(N));
if M = 0 then M:=CreateMutex(nil, True, PChar(N))
else begin
if WaitForSingleObject(M, 0) <> WAIT_ABANDONED
then Result:=False;
end;
Di:=Result;
end;
{$else}
var
Fn: string;
Di: boolean = false;
function ThisIsAnOnlyInstance: boolean;
var
i: integer;
t: Text;
s: stat;
begin
Result:=True;
Fn:= '/tmp/.' + ChangeFileExt(ExtractFileName(ParamStr(0)),'') + 'SingleInstanceMutex';
Try
if FileExists(Fn) then begin
i:=0;
AssignFile(t, Fn);
Reset(t);
Readln(t, i);
CloseFile(t);
if i = fpGetPid() then Exit
else
if DirectoryExists('/proc/' + IntToStr(i)) then begin
if not FileExists('/proc/' + IntToStr(i) + '/exe') //I'm unsure if
// any *nix creates one or it's just my distribution
or ((ExtractFileName(fpReadLink ('/proc/' + IntToStr(i) + '/exe')) = ExtractFileName(ParamStr(0)))
and not ((Length(ParamStr(0)) >=8)and(copy(ParamStr(0),1, 8) <> '/tmp/upx')))
then begin
Exit(False);
end;
end;
end;
AssignFile(t, Fn);
Rewrite(t);
Writeln(t, fpGetPid());
CloseFile(t);
Except
End;
Di:=Result;
end;
{$endif}
initialization
finalization
Try
{$ifdef win32}
if Di then ReleaseMutex(M);
{$else}
if Di and FileExists(Fn) then DeleteFile(Fn);
{$endif}
Except End;
end.
