http://homepage3.nifty.com/isayan/kxsigroute.html
// http://homepage3.nifty.com/isayan/kylixTips.html
// http://homepage3.nifty.com/isayan/kxsigroute.html
program Kylix_Signal;
{$APPTYPE CONSOLE}
uses
LibC, SysUtils;
procedure SignalSet(func:TSignalHandler);
var
smask: TSigset;
act: TSigAction;
begin
(* Signal mask setting *)
sigemptyset(smask);
sigaddset(smask,SIGINT);
sigaddset(smask,SIGTERM);
act.__sigaction_handler := func;
act.sa_mask := smask;
act.sa_flags := 0;
(* Signal exit function registered *)
sigaction(SIGINT, @act, nil);
sigaction(SIGTERM, @act, nil);
end;
procedure SignalHandle(sig_num: integer);
begin
// Writeln('(* sig_num *) : ' + IntToStr(sig_num));
// Writeln('(* SIGTERM *) : ' + IntToStr(SIGTERM));
// Writeln('(* SIGINT *) : ' + IntToStr(SIGINT));
case (sig_num) of
-4, SIGTERM:
begin
Writeln('(* kill *)');
end;
SIGINT:
begin
Writeln('(* Ctrl+C *)');
end;
end;
end;
begin
// Setting signal
SignalSet(@SignalHandle);
Repeat
WriteLn('heheheheheeheheh');
Sleep(10000);
Until False;
end.
In addition to the OP.
Would it be something to consider: a switch (define) to include or exclude the whole of testing (and the crt unit, that is only needed for cosmetics during testing).
In production, SynCommons without testing framework would be ok (and leaner).
I found this:
http://forum.lazarus.freepascal.org/ind … ic=13335.0
Sounds like if once FPC's crt unit is linked to the application:
- SIGINT is caught but do not end the process;
- use manual Ctrl+C keypress track.
With Synopse.inc and without SynCommons, the console app can respond to SIGINT.
]]>program project1;
{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER
uses
{$IFDEF UNIX}{$IFDEF UseCThreads} cthreads, {$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp,
BaseUnix, SynCommons;
// BaseUnix;
type
TMyApplication = class(TCustomApplication)
protected
procedure DoRun; override;
end;
procedure TMyApplication.DoRun;
begin
Sleep(3000);
WriteLn('DoRun');
// stop program loop
// Terminate;
end;
Procedure DoSig(sig : cint);cdecl;
begin
writeln('Receiving signal: ',sig);
end;
var
// http://www.freepascal.org/docs-html/rtl/oldlinux/sigaction.html
oa,na: PSigActionRec;
Application: TMyApplication;
begin
new(na);
new(oa);
na^.sa_Handler:=SigActionHandler(@DoSig);
fillchar(na^.Sa_Mask,sizeof(na^.sa_mask),#0);
na^.Sa_Flags:=0;
{$ifdef Linux} // Linux specific
na^.Sa_Restorer:=Nil;
{$endif}
if fpSigAction(SIGINT,na,oa)<>0 then
// if fpSigAction(SIGTERM,na,oa)<>0 then
begin
writeln('Error: ',fpgeterrno,'.');
halt(1);
end;
Application:=TMyApplication.Create(nil);
Application.StopOnException:=True;
Application.Title:='My Application';
Application.Run;
Application.Free;
Writeln ('Exit now...');
end.
Console application code:
program project1;
{$mode delphi}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads} cthreads, {$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp,
// BaseUnix, SynCommons;
BaseUnix;
type
TMyApplication = class(TCustomApplication)
protected
procedure DoRun; override;
end;
procedure TMyApplication.DoRun;
begin
Sleep(3000);
WriteLn('DoRun');
// stop program loop
// Terminate;
end;
Procedure DoSig(sig : cint);cdecl;
begin
writeln('Receiving signal: ',sig);
end;
var
// http://www.freepascal.org/docs-html/rtl/oldlinux/sigaction.html
oa,na: PSigActionRec;
Application: TMyApplication;
begin
new(na);
new(oa);
na^.sa_Handler:=SigActionHandler(@DoSig);
fillchar(na^.Sa_Mask,sizeof(na^.sa_mask),#0);
na^.Sa_Flags:=0;
{$ifdef Linux} // Linux specific
na^.Sa_Restorer:=Nil;
{$endif}
if fpSigAction(SIGINT,na,oa)<>0 then
// if fpSigAction(SIGTERM,na,oa)<>0 then
begin
writeln('Error: ',fpgeterrno,'.');
halt(1);
end;
Application:=TMyApplication.Create(nil);
Application.StopOnException:=True;
Application.Title:='My Application';
Application.Run;
Application.Free;
Writeln ('Exit now...');
end.
When SynCommons is not used, the application can react to SIGINT (Ctrl+C), as shown below:
[xli@localhost _Delphi_Proj_]$ ./project1
DoRun
Receiving signal: 2
Receiving signal: 2
Receiving signal: 2
DoRun
DoRun
However, when SynCommons is used, the application can NOT react to SIGINT (Ctrl+C), as shown below:
[xli@localhost _Delphi_Proj_]$ ./project1
DoRun
DoRun
DoRun
Could you help to comment on the reason and the possible workaround ? Many thanks !
]]>