From: plugwash <plugwash@p10link.net>
Date: Mon, 26 Jan 2009 01:16:13 +0000 (+0000)
Subject: add unitfork.pas relicensed under zlib with bewares permission
X-Git-Url: http://www.lcore.org/git/lcore.git/commitdiff_plain/69b439a013e03cd1d3eb13da8bbbc20aa5bf5184?hp=be01aa2e4e4e54fd8bb3ea27ac3c6b7978553b6e

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 3770b19..b58e14a 100755
--- a/lcoretest.dpr
+++ b/lcoretest.dpr
@@ -11,7 +11,10 @@ uses
   dnsasync,
   binipstuff,
   sysutils,
-  dnssync;
+  dnssync,
+  //we don't actually make any use of lmessages in this app, we just
+  //include it to check if it compiles ok ;)
+  lmessages;
 {$ifdef win32}
   {$R *.RES}
 {$endif}
diff --git a/unitfork.pas b/unitfork.pas
new file mode 100755
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;
+
+interface
+
+procedure dofork(const programname:string);
+procedure writepid;
+function checkpid(const filename:string):boolean;
+procedure deletepid;
+
+implementation
+
+uses
+  {$ifdef VER1_0}
+    linux,
+  {$else}
+    baseunix,unix,unixutil,
+  {$endif}
+  sysutils;
+
+{$include unixstuff.inc}
+
+const
+  F_WRLCK=2;
+
+var
+  pidfilename:string;
+  pidfile:text;
+
+procedure dofork(const programname:string);
+var
+  a:integer;
+begin
+  //writeln('dofork entered');
+  //if (paramstr(1) = 'foreground') or (paramstr(1)='debug') then exit; {no fork}
+  a := fork;
+  if a = 0 then exit; {i'm the child}
+  if a < 0 then begin
+    writeln('failed to run in background, try "'+programname+' foreground" if it doesnt work otherwise');
+    halt; {failed}
+  end;
+
+  halt; {i'm the parent}
+end;
+
+function checkpid;
+var
+  handle:thandle;
+
+begin
+  result := false;
+  pidfilename := '';
+  //debugout(filename);
+  assignfile(pidfile,filename);
+  filemode := 2;
+  {opening file to get a fd for it. can't rewrite because a lock appears to allow the rewrite}
+  {$i-}reset(pidfile);{$i+}
+  if ioresult <> 0 then begin
+    {$i-}rewrite(pidfile);{$i+}
+    if ioresult <> 0 then exit;
+  end;
+
+  handle := getfs(pidfile);
+
+  //debugout('got handle');
+  {check if locking is possible: it's not if other process still runs}
+  {$ifdef VER1_0}
+  if not flock(handle,LOCK_EX or LOCK_NB)
+  {$else}
+  if flock(handle,LOCK_EX or LOCK_NB) <> 0
+  {$endif}
+  then begin
+    //debugout('failed to lock pid file');
+    close(pidfile);
+    exit;
+  end;
+  rewrite(pidfile);
+  {lock again because the rewrite removes the lock}
+  {$ifdef VER1_0}
+  if not flock(handle,LOCK_EX or LOCK_NB)
+  {$else}
+  if flock(handle,LOCK_EX or LOCK_NB) <> 0
+  {$endif}
+  then raise exception.create('flock failed '+inttostr(linuxerror));
+  pidfilename := filename;
+  result := true;
+end;
+
+
+procedure writepid;
+begin
+  writeln(pidfile,getpid);
+  flush(pidfile);
+end;
+
+procedure deletepid;
+begin
+  if pidfilename = '' then exit;
+  try
+    {$i-}
+    closefile(pidfile);
+    erase(pidfile);
+    {$i+}
+    ioresult;
+  except
+    {}
+  end;
+  pidfilename := '';
+end;
+
+end.