add unitfork.pas relicensed under zlib with bewares permission

git-svn-id: file:///svnroot/lcore/trunk@29 b1de8a11-f9be-4011-bde0-cc7ace90066a

diff --git a/lcoretest.dpr b/lcoretest.dpr
index 3770b19b49116b7f6d53ace2bcde91b04fc492f3..b58e14a64e4fd66edbf4eb85a86baf87e6e16b6a 100755 (executable)
--- a/lcoretest.dpr
+++ b/lcoretest.dpr
@@ -11,7 +11,10 @@ uses
   dnsasync,\r
   binipstuff,\r
   sysutils,\r
-  dnssync;\r
+  dnssync,\r
+  //we don't actually make any use of lmessages in this app, we just\r
+  //include it to check if it compiles ok ;)\r
+  lmessages;\r
 {$ifdef win32}\r
   {$R *.RES}\r
 {$endif}\r

diff --git a/unitfork.pas b/unitfork.pas
new file mode 100755 (executable)
index 0000000..5239fc0
--- /dev/null
+++ b/unitfork.pas
@@ -0,0 +1,114 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+  For conditions of distribution and use, see copyright notice in zlib_license.txt
+    which is included in the package
+      ----------------------------------------------------------------------------- }
+unit unitfork;\r
+\r
+interface\r
+\r
+procedure dofork(const programname:string);\r
+procedure writepid;\r
+function checkpid(const filename:string):boolean;\r
+procedure deletepid;\r
+\r
+implementation\r
+\r
+uses\r
+  {$ifdef VER1_0}\r
+    linux,\r
+  {$else}\r
+    baseunix,unix,unixutil,\r
+  {$endif}\r
+  sysutils;
+\r
+{$include unixstuff.inc}\r
+\r
+const\r
+  F_WRLCK=2;\r
+\r
+var\r
+  pidfilename:string;\r
+  pidfile:text;\r
+\r
+procedure dofork(const programname:string);\r
+var\r
+  a:integer;\r
+begin\r
+  //writeln('dofork entered');\r
+  //if (paramstr(1) = 'foreground') or (paramstr(1)='debug') then exit; {no fork}\r
+  a := fork;\r
+  if a = 0 then exit; {i'm the child}\r
+  if a < 0 then begin\r
+    writeln('failed to run in background, try "'+programname+' foreground" if it doesnt work otherwise');\r
+    halt; {failed}\r
+  end;\r
+\r
+  halt; {i'm the parent}\r
+end;\r
+\r
+function checkpid;\r
+var\r
+  handle:thandle;\r
+\r
+begin\r
+  result := false;\r
+  pidfilename := '';\r
+  //debugout(filename);\r
+  assignfile(pidfile,filename);\r
+  filemode := 2;\r
+  {opening file to get a fd for it. can't rewrite because a lock appears to allow the rewrite}\r
+  {$i-}reset(pidfile);{$i+}\r
+  if ioresult <> 0 then begin\r
+    {$i-}rewrite(pidfile);{$i+}\r
+    if ioresult <> 0 then exit;\r
+  end;\r
+\r
+  handle := getfs(pidfile);\r
+\r
+  //debugout('got handle');\r
+  {check if locking is possible: it's not if other process still runs}\r
+  {$ifdef VER1_0}\r
+  if not flock(handle,LOCK_EX or LOCK_NB)\r
+  {$else}\r
+  if flock(handle,LOCK_EX or LOCK_NB) <> 0\r
+  {$endif}\r
+  then begin\r
+    //debugout('failed to lock pid file');\r
+    close(pidfile);\r
+    exit;\r
+  end;\r
+  rewrite(pidfile);\r
+  {lock again because the rewrite removes the lock}\r
+  {$ifdef VER1_0}\r
+  if not flock(handle,LOCK_EX or LOCK_NB)\r
+  {$else}\r
+  if flock(handle,LOCK_EX or LOCK_NB) <> 0\r
+  {$endif}\r
+  then raise exception.create('flock failed '+inttostr(linuxerror));\r
+  pidfilename := filename;\r
+  result := true;\r
+end;\r
+\r
+\r
+procedure writepid;\r
+begin\r
+  writeln(pidfile,getpid);\r
+  flush(pidfile);\r
+end;\r
+\r
+procedure deletepid;\r
+begin\r
+  if pidfilename = '' then exit;\r
+  try\r
+    {$i-}\r
+    closefile(pidfile);\r
+    erase(pidfile);\r
+    {$i+}\r
+    ioresult;\r
+  except\r
+    {}\r
+  end;\r
+  pidfilename := '';\r
+end;\r
+\r
+end.\r