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