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

Annotation of /trunk/unitfork.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 149 - (hide annotations)
Sun Sep 10 20:02:13 2017 UTC (3 years, 1 month 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 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 plugwash 149 {$ifdef fpc}
7     {$mode delphi}
8     {$endif}
9 plugwash 29 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 plugwash 60 baseunix,unix,unixutil,sockets,
23 plugwash 29 {$endif}
24 plugwash 30 sysutils;
25 plugwash 29
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.22