/[lcore]/trunk/unitfork.pas
ViewVC logotype

Annotation of /trunk/unitfork.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.22