mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-12-16 05:10:34 +01:00
f6d452c2c0
unit's initialization code in case we're in a library
+ implemented InquireSignal(), AbandonSignalHandler(), HookSignal() and
UnhookSignal() in the sysutils unit
* for Kylix compatibility, these routines support operating on
SIGINT and SIGQUIT as well, although they are not hooked by default
by FPC. The run time errors/exception codes for these signals are
resp. 217 and 233 (same as in Kylix; I changed ENoWideStringSupport
to 234).
* changed the BSD syscall version of fpsigaction to use pointer
rather than "var" arguments (compatible with other targets, and
required to be able to pass nil arguments inside the system unit)
-> together fixes mantis #12704
git-svn-id: trunk@13077 -
108 lines
2.1 KiB
ObjectPascal
108 lines
2.1 KiB
ObjectPascal
{ %norun }
|
|
{ %target=darwin,linux,freebsd,solaris,beos,haiku }
|
|
|
|
{$mode delphi}
|
|
|
|
{$ifdef darwin}
|
|
{$PIC+}
|
|
{$endif darwin}
|
|
|
|
{$ifdef CPUX86_64}
|
|
{$ifndef WINDOWS}
|
|
{$PIC+}
|
|
{$endif WINDOWS}
|
|
{$endif CPUX86_64}
|
|
|
|
library tw12704a;
|
|
|
|
uses
|
|
SysUtils;
|
|
|
|
procedure initsignals;
|
|
var
|
|
p: pointer;
|
|
i: longint;
|
|
begin
|
|
// check that none of the handlers have been yet by the library's init code
|
|
for i:=RTL_SIGINT to RTL_SIGLAST do
|
|
if (InquireSignal(i) <> ssNotHooked) then
|
|
halt(1);
|
|
|
|
// hook standard signals
|
|
HookSignal(RTL_SIGDEFAULT);
|
|
for i:=RTL_SIGINT to RTL_SIGLAST do
|
|
case i of
|
|
RTL_SIGINT,
|
|
RTL_SIGQUIT:
|
|
if (InquireSignal(i) <> ssNotHooked) then
|
|
halt(2);
|
|
RTL_SIGFPE,
|
|
RTL_SIGSEGV,
|
|
RTL_SIGILL,
|
|
RTL_SIGBUS:
|
|
if (InquireSignal(i) <> ssHooked) then
|
|
halt(3);
|
|
else
|
|
halt(4);
|
|
end;
|
|
|
|
// unhook sigill
|
|
UnHookSignal(RTL_SIGILL);
|
|
for i:=RTL_SIGINT to RTL_SIGLAST do
|
|
case i of
|
|
RTL_SIGINT,
|
|
RTL_SIGILL,
|
|
RTL_SIGQUIT:
|
|
if (InquireSignal(i) <> ssNotHooked) then
|
|
halt(5);
|
|
RTL_SIGFPE,
|
|
RTL_SIGSEGV,
|
|
RTL_SIGBUS:
|
|
if (InquireSignal(i) <> ssHooked) then
|
|
halt(6);
|
|
end;
|
|
|
|
// check whether installed signal handler actually works
|
|
(*
|
|
try
|
|
p:=nil;
|
|
longint(p^):=1;
|
|
except
|
|
end;
|
|
*)
|
|
end;
|
|
|
|
|
|
procedure testsignals; cdecl;
|
|
var
|
|
i: longint;
|
|
begin
|
|
// called from program -> it has overridden our signal handlers
|
|
// when this routine is called, it will have unhooked sigbus, so
|
|
// that one should still belong to us
|
|
// we previously unhooked sigill, so that one should still be
|
|
// unhooked as far as we are concerned
|
|
for i:=RTL_SIGINT to RTL_SIGLAST do
|
|
case i of
|
|
RTL_SIGINT,
|
|
RTL_SIGILL,
|
|
RTL_SIGQUIT:
|
|
if (InquireSignal(i) <> ssNothooked) then
|
|
halt(7);
|
|
RTL_SIGFPE,
|
|
RTL_SIGSEGV:
|
|
if (InquireSignal(i) <> ssOverridden) then
|
|
halt(8);
|
|
RTL_SIGBUS:
|
|
if (InquireSignal(i) <> ssHooked) then
|
|
halt(9);
|
|
end;
|
|
end;
|
|
|
|
exports
|
|
testsignals;
|
|
|
|
begin
|
|
initsignals;
|
|
end.
|