| 1 |
{ Copyright (C) 2005 Bas Steendijk and Peter Green
|
| 2 |
For conditions of distribution and use, see copyright notice in zlib_license.txt
|
| 3 |
which is included in the package
|
| 4 |
----------------------------------------------------------------------------- }
|
| 5 |
unit unitfork;
|
| 6 |
{$ifdef fpc}
|
| 7 |
{$mode delphi}
|
| 8 |
{$endif}
|
| 9 |
interface
|
| 10 |
|
| 11 |
procedure dofork(const programname:string);
|
| 12 |
procedure writepid;
|
| 13 |
function checkpid(const filename:string):boolean;
|
| 14 |
procedure deletepid;
|
| 15 |
|
| 16 |
implementation
|
| 17 |
|
| 18 |
uses
|
| 19 |
{$ifdef VER1_0}
|
| 20 |
linux,
|
| 21 |
{$else}
|
| 22 |
baseunix,unix,unixutil,sockets,
|
| 23 |
{$endif}
|
| 24 |
sysutils;
|
| 25 |
|
| 26 |
{$include unixstuff.inc}
|
| 27 |
|
| 28 |
const
|
| 29 |
F_WRLCK=2;
|
| 30 |
|
| 31 |
var
|
| 32 |
pidfilename:string;
|
| 33 |
pidfile:text;
|
| 34 |
|
| 35 |
procedure dofork(const programname:string);
|
| 36 |
var
|
| 37 |
a:integer;
|
| 38 |
begin
|
| 39 |
//writeln('dofork entered');
|
| 40 |
//if (paramstr(1) = 'foreground') or (paramstr(1)='debug') then exit; {no fork}
|
| 41 |
a := fork;
|
| 42 |
if a = 0 then exit; {i'm the child}
|
| 43 |
if a < 0 then begin
|
| 44 |
writeln('failed to run in background, try "'+programname+' foreground" if it doesnt work otherwise');
|
| 45 |
halt; {failed}
|
| 46 |
end;
|
| 47 |
|
| 48 |
halt; {i'm the parent}
|
| 49 |
end;
|
| 50 |
|
| 51 |
function checkpid;
|
| 52 |
var
|
| 53 |
handle:thandle;
|
| 54 |
|
| 55 |
begin
|
| 56 |
result := false;
|
| 57 |
pidfilename := '';
|
| 58 |
//debugout(filename);
|
| 59 |
assignfile(pidfile,filename);
|
| 60 |
filemode := 2;
|
| 61 |
{opening file to get a fd for it. can't rewrite because a lock appears to allow the rewrite}
|
| 62 |
{$i-}reset(pidfile);{$i+}
|
| 63 |
if ioresult <> 0 then begin
|
| 64 |
{$i-}rewrite(pidfile);{$i+}
|
| 65 |
if ioresult <> 0 then exit;
|
| 66 |
end;
|
| 67 |
|
| 68 |
handle := getfs(pidfile);
|
| 69 |
|
| 70 |
//debugout('got handle');
|
| 71 |
{check if locking is possible: it's not if other process still runs}
|
| 72 |
{$ifdef VER1_0}
|
| 73 |
if not flock(handle,LOCK_EX or LOCK_NB)
|
| 74 |
{$else}
|
| 75 |
if flock(handle,LOCK_EX or LOCK_NB) <> 0
|
| 76 |
{$endif}
|
| 77 |
then begin
|
| 78 |
//debugout('failed to lock pid file');
|
| 79 |
close(pidfile);
|
| 80 |
exit;
|
| 81 |
end;
|
| 82 |
rewrite(pidfile);
|
| 83 |
{lock again because the rewrite removes the lock}
|
| 84 |
{$ifdef VER1_0}
|
| 85 |
if not flock(handle,LOCK_EX or LOCK_NB)
|
| 86 |
{$else}
|
| 87 |
if flock(handle,LOCK_EX or LOCK_NB) <> 0
|
| 88 |
{$endif}
|
| 89 |
then raise exception.create('flock failed '+inttostr(linuxerror));
|
| 90 |
pidfilename := filename;
|
| 91 |
result := true;
|
| 92 |
end;
|
| 93 |
|
| 94 |
|
| 95 |
procedure writepid;
|
| 96 |
begin
|
| 97 |
writeln(pidfile,getpid);
|
| 98 |
flush(pidfile);
|
| 99 |
end;
|
| 100 |
|
| 101 |
procedure deletepid;
|
| 102 |
begin
|
| 103 |
if pidfilename = '' then exit;
|
| 104 |
try
|
| 105 |
{$i-}
|
| 106 |
closefile(pidfile);
|
| 107 |
erase(pidfile);
|
| 108 |
{$i+}
|
| 109 |
ioresult;
|
| 110 |
except
|
| 111 |
{}
|
| 112 |
end;
|
| 113 |
pidfilename := '';
|
| 114 |
end;
|
| 115 |
|
| 116 |
end.
|
Parent Directory
| 
Revision Log