lsignal.pas

   1 {lsocket.pas}\r
   2 \r
   3 {signal code by plugwash}\r
   4 \r
   5 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   6   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   7   which is included in the package\r
   8   ----------------------------------------------------------------------------- }\r
   9       \r
  10 unit lsignal;\r
  11 {$mode delphi}\r
  12 interface\r
  13   uses sysutils,\r
  14     {$ifdef VER1_0}\r
  15       linux,\r
  16     {$else}\r
  17       baseunix,unix,unixutil,sockets,\r
  18     {$endif}\r
  19     classes,lcore,lloopback;\r
  20 \r
  21   type\r
  22     tsignalevent=procedure(sender:tobject;signal:integer) of object;\r
  23     tlsignal=class(tcomponent)\r
  24     public\r
  25       onsignal           : tsignalevent      ;\r
  26       prevsignal         : tlsignal          ;\r
  27       nextsignal         : tlsignal          ;\r
  28 \r
  29       constructor create(aowner:tcomponent);override;\r
  30       destructor destroy;override;\r
  31     end;\r
  32 \r
  33   \r
  34   procedure starthandlesignal(signal:integer);\r
  35 \r
  36 var\r
  37   firstsignal : tlsignal;\r
  38   blockset : sigset;\r
  39   signalloopback                        : tlloopback ;\r
  40   \r
  41 implementation\r
  42 {$include unixstuff.inc}\r
  43 \r
  44 constructor tlsignal.create;\r
  45 begin\r
  46   inherited create(AOwner);\r
  47   nextsignal := firstsignal;\r
  48   prevsignal := nil;\r
  49 \r
  50   if assigned(nextsignal) then nextsignal.prevsignal := self;\r
  51   firstsignal := self;\r
  52 \r
  53   //interval := 1000;\r
  54   //enabled := true;\r
  55   //released := false;\r
  56 end;\r
  57 \r
  58 destructor tlsignal.destroy;\r
  59 begin\r
  60   if prevsignal <> nil then begin\r
  61     prevsignal.nextsignal := nextsignal;\r
  62   end else begin\r
  63     firstsignal := nextsignal;\r
  64   end;\r
  65   if nextsignal <> nil then begin\r
  66     nextsignal.prevsignal := prevsignal;\r
  67   end;\r
  68   inherited destroy;\r
  69 end;\r
  70 {$ifdef linux}\r
  71   {$ifdef ver1_9_8}\r
  72     {$define needsignalworkaround}\r
  73   {$endif}\r
  74   {$ifdef ver2_0_0}\r
  75     {$define needsignalworkaround}\r
  76   {$endif}\r
  77   {$ifdef ver2_0_2}\r
  78     {$define needsignalworkaround}\r
  79   {$endif}\r
  80 {$endif}\r
  81 {$ifdef needsignalworkaround}\r
  82   //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken\r
  83   type\r
  84     TSysParam  = Longint;\r
  85     TSysResult = longint;\r
  86   const\r
  87             syscall_nr_sigaction                = 67;\r
  88   //function Do_SysCall(sysnr:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0';\r
  89   //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1';\r
  90   //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2';\r
  91   function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3';\r
  92   //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4';\r
  93   //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5';\r
  94 \r
  95   function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION'];\r
  96   {\r
  97     Change action of process upon receipt of a signal.\r
  98     Signum specifies the signal (all except SigKill and SigStop).\r
  99     If Act is non-nil, it is used to specify the new action.\r
 100     If OldAct is non-nil the previous action is saved there.\r
 101   }\r
 102   begin\r
 103   //writeln('fucking');\r
 104   {$ifdef RTSIGACTION}\r
 105     {$ifdef cpusparc}\r
 106       { Sparc has an extra stub parameter }\r
 107       Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8));\r
 108     {$else cpusparc}\r
 109       Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8));\r
 110     {$endif cpusparc}\r
 111   {$else RTSIGACTION}\r
 112     //writeln('nice');\r
 113     Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));\r
 114   {$endif RTSIGACTION}\r
 115   end;\r
 116 {$endif}\r
 117 \r
 118 // cdecl procedures are not name mangled\r
 119 // so USING something unlikely to cause collisions in the global namespace\r
 120 // is a good idea\r
 121 procedure lsignal_handler( Sig : Integer);cdecl;\r
 122 var\r
 123   currentsignal : tlsignal;\r
 124 begin\r
 125 //  writeln('in lsignal_handler');\r
 126   currentsignal := firstsignal;\r
 127   while assigned(currentsignal) do begin\r
 128     if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig);\r
 129     currentsignal := currentsignal.nextsignal;\r
 130 \r
 131   end;\r
 132 //  writeln('about to send down signalloopback');\r
 133   if assigned(signalloopback) then begin\r
 134     signalloopback.sendstr(' ');\r
 135   end;\r
 136 //  writeln('left lsignal_handler');\r
 137 end;\r
 138 \r
 139 {$ifdef freebsd}\r
 140 \r
 141 {$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))}\r
 142 procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl;\r
 143 {$else}\r
 144 procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl;\r
 145 {$endif}\r
 146 \r
 147 begin\r
 148   lsignal_handler(signal);\r
 149 end;\r
 150 {$endif}\r
 151 \r
 152 \r
 153 const\r
 154   allbitsset=-1;\r
 155   {$ifdef ver1_0}\r
 156     saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
 157   {$else}\r
 158     {$ifdef darwin}\r
 159       saction : sigactionrec = (sa_handler:sigactionhandler(lsignal_handler);sa_flags:0);\r
 160     {$else}\r
 161       {$ifdef freebsd}\r
 162         //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
 163         {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
 164           saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0);\r
 165         {$else}\r
 166           saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
 167         {$endif}\r
 168                                                           \r
 169       {$else}\r
 170         {$ifdef ver1_9_2}\r
 171           saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
 172         {$else}\r
 173           //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
 174           {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
 175             saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler);sa_flags:0;sa_restorer:nil);\r
 176           {$else}\r
 177             saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler));\r
 178           {$endif}\r
 179         {$endif}\r
 180       {$endif}\r
 181     {$endif}\r
 182   {$endif}\r
 183 procedure starthandlesignal(signal:integer);\r
 184 begin\r
 185   if signal in ([0..31]-[sigkill,sigstop]) then begin\r
 186     sigprocmask(SIG_BLOCK,@blockset,nil);\r
 187     sigaction(signal,@saction,nil)\r
 188   end else begin\r
 189     raise exception.create('invalid signal number')\r
 190   end;\r
 191 end;\r
 192 \r
 193 initialization\r
 194   fillchar(blockset,sizeof(blockset),0);\r
 195   blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv);\r
 196   {$ifdef ver1_0}\r
 197     saction.sa_mask := blockset[0];\r
 198   {$else}\r
 199     saction.sa_mask := blockset;\r
 200   {$endif}\r
 201 end.\r