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

Contents of /trunk/unitfork.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 149 - (show annotations)
Sun Sep 10 20:02:13 2017 UTC (3 months ago) by plugwash
File size: 2524 byte(s)
Replace obsolete/broken lcoregtklaz with new lcorelazarus
Rename lmessages to lcoremessages due to unit name conflict with Lazarus

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.

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