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

Contents of /trunk/unitfork.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 61 - (show annotations)
Thu Feb 4 22:47:07 2010 UTC (10 years, 8 months ago) by plugwash
File size: 2484 byte(s)
set line ending property on files to hopefully avoid line ending problems in future

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
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 baseunix,unix,unixutil,sockets,
21 {$endif}
22 sysutils;
23
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
svn:executable *

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