Chebmaster
20-03-2007, 05:07 PM
Here's my unit, I finished it at last! Tested, tried, never lets you down, correctly determines the presence/absence of the previous instance even if it crashed or was KILL'ed/ended via the TaskManager. :D
[Updatet THRICE. See the last posts.]
Win32: both FPC and Delphi, Linux: FPC only.
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.
[Updatet THRICE. See the last posts.]
Win32: both FPC and Delphi, Linux: FPC only.
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.