unitfork.pas

   1 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   2   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   3     which is included in the package\r
   4       ----------------------------------------------------------------------------- }\r
   5 unit unitfork;\r
   6 \r
   7 interface\r
   8 \r
   9 procedure dofork(const programname:string);\r
  10 procedure writepid;\r
  11 function checkpid(const filename:string):boolean;\r
  12 procedure deletepid;\r
  13 \r
  14 implementation\r
  15 \r
  16 uses\r
  17   {$ifdef VER1_0}\r
  18     linux,\r
  19   {$else}\r
  20     baseunix,unix,unixutil,sockets,\r
  21   {$endif}\r
  22   sysutils;\r
  23 \r
  24 {$include unixstuff.inc}\r
  25 \r
  26 const\r
  27   F_WRLCK=2;\r
  28 \r
  29 var\r
  30   pidfilename:string;\r
  31   pidfile:text;\r
  32 \r
  33 procedure dofork(const programname:string);\r
  34 var\r
  35   a:integer;\r
  36 begin\r
  37   //writeln('dofork entered');\r
  38   //if (paramstr(1) = 'foreground') or (paramstr(1)='debug') then exit; {no fork}\r
  39   a := fork;\r
  40   if a = 0 then exit; {i'm the child}\r
  41   if a < 0 then begin\r
  42     writeln('failed to run in background, try "'+programname+' foreground" if it doesnt work otherwise');\r
  43     halt; {failed}\r
  44   end;\r
  45 \r
  46   halt; {i'm the parent}\r
  47 end;\r
  48 \r
  49 function checkpid;\r
  50 var\r
  51   handle:thandle;\r
  52 \r
  53 begin\r
  54   result := false;\r
  55   pidfilename := '';\r
  56   //debugout(filename);\r
  57   assignfile(pidfile,filename);\r
  58   filemode := 2;\r
  59   {opening file to get a fd for it. can't rewrite because a lock appears to allow the rewrite}\r
  60   {$i-}reset(pidfile);{$i+}\r
  61   if ioresult <> 0 then begin\r
  62     {$i-}rewrite(pidfile);{$i+}\r
  63     if ioresult <> 0 then exit;\r
  64   end;\r
  65 \r
  66   handle := getfs(pidfile);\r
  67 \r
  68   //debugout('got handle');\r
  69   {check if locking is possible: it's not if other process still runs}\r
  70   {$ifdef VER1_0}\r
  71   if not flock(handle,LOCK_EX or LOCK_NB)\r
  72   {$else}\r
  73   if flock(handle,LOCK_EX or LOCK_NB) <> 0\r
  74   {$endif}\r
  75   then begin\r
  76     //debugout('failed to lock pid file');\r
  77     close(pidfile);\r
  78     exit;\r
  79   end;\r
  80   rewrite(pidfile);\r
  81   {lock again because the rewrite removes the lock}\r
  82   {$ifdef VER1_0}\r
  83   if not flock(handle,LOCK_EX or LOCK_NB)\r
  84   {$else}\r
  85   if flock(handle,LOCK_EX or LOCK_NB) <> 0\r
  86   {$endif}\r
  87   then raise exception.create('flock failed '+inttostr(linuxerror));\r
  88   pidfilename := filename;\r
  89   result := true;\r
  90 end;\r
  91 \r
  92 \r
  93 procedure writepid;\r
  94 begin\r
  95   writeln(pidfile,getpid);\r
  96   flush(pidfile);\r
  97 end;\r
  98 \r
  99 procedure deletepid;\r
 100 begin\r
 101   if pidfilename = '' then exit;\r
 102   try\r
 103     {$i-}\r
 104     closefile(pidfile);\r
 105     erase(pidfile);\r
 106     {$i+}\r
 107     ioresult;\r
 108   except\r
 109     {}\r
 110   end;\r
 111   pidfilename := '';\r
 112 end;\r
 113 \r
 114 end.\r