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   {$IF FPC_FULLVERSION>=20602}\r
  69   handle := getfilehandle(pidfile);\r
  70   {$else}\r
  71   handle := getfs(pidfile);\r
  72   {$endif}\r
  73 \r
  74   //debugout('got handle');\r
  75   {check if locking is possible: it's not if other process still runs}\r
  76   {$ifdef VER1_0}\r
  77   if not flock(handle,LOCK_EX or LOCK_NB)\r
  78   {$else}\r
  79   if flock(handle,LOCK_EX or LOCK_NB) <> 0\r
  80   {$endif}\r
  81   then begin\r
  82     //debugout('failed to lock pid file');\r
  83     close(pidfile);\r
  84     exit;\r
  85   end;\r
  86   rewrite(pidfile);\r
  87   {lock again because the rewrite removes the lock}\r
  88   {$ifdef VER1_0}\r
  89   if not flock(handle,LOCK_EX or LOCK_NB)\r
  90   {$else}\r
  91   if flock(handle,LOCK_EX or LOCK_NB) <> 0\r
  92   {$endif}\r
  93   then raise exception.create('flock failed '+inttostr(linuxerror));\r
  94   pidfilename := filename;\r
  95   result := true;\r
  96 end;\r
  97 \r
  98 \r
  99 procedure writepid;\r
 100 begin\r
 101   writeln(pidfile,getpid);\r
 102   flush(pidfile);\r
 103 end;\r
 104 \r
 105 procedure deletepid;\r
 106 begin\r
 107   if pidfilename = '' then exit;\r
 108   try\r
 109     {$i-}\r
 110     closefile(pidfile);\r
 111     erase(pidfile);\r
 112     {$i+}\r
 113     ioresult;\r
 114   except\r
 115     {}\r
 116   end;\r
 117   pidfilename := '';\r
 118 end;\r
 119 \r
 120 end.\r