lcore/trunk/lsignal.pas

{lsocket.pas}

{signal code by plugwash}

{ 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 lsignal;
{$mode delphi}
interface
  uses sysutils,
    {$ifdef VER1_0}
      linux,
    {$else}
      baseunix,unix,unixutil,sockets,
    {$endif}
    classes,lcore,lloopback;

  type
    tsignalevent=procedure(sender:tobject;signal:integer) of object;
    tlsignal=class(tcomponent)
    public
      onsignal           : tsignalevent      ;
      prevsignal         : tlsignal          ;
      nextsignal         : tlsignal          ;

      constructor create(aowner:tcomponent);override;
      destructor destroy;override;
    end;

  
  procedure starthandlesignal(signal:integer);

var
  firstsignal : tlsignal;
  blockset : sigset;
  signalloopback                        : tlloopback ;
  
implementation
{$include unixstuff.inc}

constructor tlsignal.create;
begin
  inherited create(AOwner);
  nextsignal := firstsignal;
  prevsignal := nil;

  if assigned(nextsignal) then nextsignal.prevsignal := self;
  firstsignal := self;

  //interval := 1000;
  //enabled := true;
  //released := false;
end;

destructor tlsignal.destroy;
begin
  if prevsignal <> nil then begin
    prevsignal.nextsignal := nextsignal;
  end else begin
    firstsignal := nextsignal;
  end;
  if nextsignal <> nil then begin
    nextsignal.prevsignal := prevsignal;
  end;
  inherited destroy;
end;
{$ifdef linux}
  {$ifdef ver1_9_8}
    {$define needsignalworkaround}
  {$endif}
  {$ifdef ver2_0_0}
    {$define needsignalworkaround}
  {$endif}
  {$ifdef ver2_0_2}
    {$define needsignalworkaround}
  {$endif}
{$endif}
{$ifdef needsignalworkaround}
  //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken
  type
    TSysParam  = Longint;
    TSysResult = longint;
  const
            syscall_nr_sigaction                = 67;
  //function Do_SysCall(sysnr:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0';
  //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1';
  //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2';
  function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3';
  //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4';
  //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5';

  function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION'];
  {
    Change action of process upon receipt of a signal.
    Signum specifies the signal (all except SigKill and SigStop).
    If Act is non-nil, it is used to specify the new action.
    If OldAct is non-nil the previous action is saved there.
  }
  begin
  //writeln('fucking');
  {$ifdef RTSIGACTION}
    {$ifdef cpusparc}
      { Sparc has an extra stub parameter }
      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8));
    {$else cpusparc}
      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8));
    {$endif cpusparc}
  {$else RTSIGACTION}
    //writeln('nice');
    Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));
  {$endif RTSIGACTION}
  end;
{$endif}

// cdecl procedures are not name mangled
// so USING something unlikely to cause collisions in the global namespace
// is a good idea
procedure lsignal_handler( Sig : Integer);cdecl;
var
  currentsignal : tlsignal;
begin
//  writeln('in lsignal_handler');
  currentsignal := firstsignal;
  while assigned(currentsignal) do begin
    if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig);
    currentsignal := currentsignal.nextsignal;

  end;
//  writeln('about to send down signalloopback');
  if assigned(signalloopback) then begin
    signalloopback.sendstr(' ');
  end;
//  writeln('left lsignal_handler');
end;

{$ifdef freebsd}

{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))}
procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl;
{$else}
procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl;
{$endif}

begin
  lsignal_handler(signal);
end;
{$endif}


const
  allbitsset=-1;
  {$ifdef ver1_0}
    saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);
  {$else}
    {$ifdef darwin}
      saction : sigactionrec = (sa_handler:sigactionhandler(lsignal_handler);sa_flags:0);
    {$else}
      {$ifdef freebsd}
        //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH
        {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}
          saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0);
        {$else}
          saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);
        {$endif}
                                                          
      {$else}
        {$ifdef ver1_9_2}
          saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);
        {$else}
          //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH
          {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}
            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);
          {$else}
            saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler));
          {$endif}
        {$endif}
      {$endif}
    {$endif}
  {$endif}
procedure starthandlesignal(signal:integer);
begin
  if signal in ([0..31]-[sigkill,sigstop]) then begin
    sigprocmask(SIG_BLOCK,@blockset,nil);
    sigaction(signal,@saction,nil)
  end else begin
    raise exception.create('invalid signal number')
  end;
end;

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