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.
|