support POSIX SA_SIGINFO

Message-ID: <42DE3846.6050606@gmail.com>

p4raw-id: //depot/perl@25200

12 files changed, 129 insertions, 27 deletions

diff --git a/embed.fnc b/embed.fnc
index 7363a46939..bbafdbe6e1 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -706,8 +706,13 @@ p	|I32	|setenv_getix	|const char* nam
 #endif
 p	|void	|setdefout	|NULLOK GV* gv
 Ap	|HEK*	|share_hek	|NN const char* str|I32 len|U32 hash
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+np	|Signal_t |sighandler	|int sig|...
+Anp	|Signal_t |csighandler	|int sig|...
+#else
 np	|Signal_t |sighandler	|int sig
 Anp	|Signal_t |csighandler	|int sig
+#endif
 Ap	|SV**	|stack_grow	|NN SV** sp|NN SV**p|int n
 ApR	|I32	|start_subparse	|I32 is_format|U32 flags
 p	|void	|sub_crush_depth|NN CV* cv
diff --git a/embed.h b/embed.h
index 023d8f3898..9ab983abbc 100644
--- a/embed.h
+++ b/embed.h
@@ -750,10 +750,17 @@
 #define setdefout		Perl_setdefout
 #endif
 #define share_hek		Perl_share_hek
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
 #ifdef PERL_CORE
 #define sighandler		Perl_sighandler
 #endif
 #define csighandler		Perl_csighandler
+#else
+#ifdef PERL_CORE
+#define sighandler		Perl_sighandler
+#endif
+#define csighandler		Perl_csighandler
+#endif
 #define stack_grow		Perl_stack_grow
 #define start_subparse		Perl_start_subparse
 #ifdef PERL_CORE
@@ -2740,10 +2747,15 @@
 #define setdefout(a)		Perl_setdefout(aTHX_ a)
 #endif
 #define share_hek(a,b,c)	Perl_share_hek(aTHX_ a,b,c)
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+#ifdef PERL_CORE
+#endif
+#else
 #ifdef PERL_CORE
 #define sighandler		Perl_sighandler
 #endif
 #define csighandler		Perl_csighandler
+#endif
 #define stack_grow(a,b,c)	Perl_stack_grow(aTHX_ a,b,c)
 #define start_subparse(a,b)	Perl_start_subparse(aTHX_ a,b)
 #ifdef PERL_CORE
diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod
index 147f2db989..e7166a643d 100644
--- a/ext/POSIX/POSIX.pod
+++ b/ext/POSIX/POSIX.pod
@@ -1130,6 +1130,31 @@ Returns C<undef> on failure.  The C<signal> must be a number (like
 SIGHUP), not a string (like "SIGHUP"), though Perl does try hard
 to understand you.
 
+If you use the SA_SIGINFO flag, the signal handler will in addition to
+the first argument, the signal name, also receive a second argument, a
+hash reference, inside which are the following keys with the following
+semantics, as defined by POSIX/SUSv3:
+
+    signo       the signal number
+    errno       the error number
+    code        if this is zero or less, the signal was sent by
+                a user process and the uid and pid make sense,
+                otherwise the signal was sent by the kernel
+    pid         the process id generating the signal
+    uid         the uid of the process id generating the signal
+    status      exit value or signal for SIGCHLD
+    band        band event for SIGPOLL
+
+A third argument is also passed to the handler, which contains a copy
+of the raw binary contents of the siginfo structure: if a system has
+some non-POSIX fields, this third argument is where to unpack() them
+from.
+
+Note that not all siginfo values make sense simultaneously (some are
+valid only for certain signals, for example), and not all values make
+sense from Perl perspective, you should to consult your system's
+C<sigaction> and possibly also C<siginfo> documentation.
+
 =item siglongjmp
 
 siglongjmp() is C-specific: use L<perlfunc/die> instead.
diff --git a/ext/POSIX/t/sigaction.t b/ext/POSIX/t/sigaction.t
index bc40b7892b..6de6cfbecd 100644
--- a/ext/POSIX/t/sigaction.t
+++ b/ext/POSIX/t/sigaction.t
@@ -16,7 +16,7 @@ BEGIN{
 	}
 }
 
-use Test::More tests => 29;
+use Test::More tests => 30;
 
 use strict;
 use vars qw/$bad $bad7 $ok10 $bad18 $ok/;
@@ -190,3 +190,15 @@ SKIP: {
     kill 'SIGRTMIN', $$;
     is($sigrtmin, 1, "SIGRTMIN handler works");
 }
+
+SKIP: {
+    eval 'use POSIX qw(SA_SIGINFO); SA_SIGINFO';
+    skip("no SA_SIGINFO", 1) if $@;
+    sub hiphup {
+	is($_[1]->{pid}, $$, "SA_SIGINFO got right pid");
+    }
+    my $act = POSIX::SigAction->new('hiphup', 0, SA_SIGINFO);
+    sigaction(SIGHUP, $act);
+    kill 'HUP', $$;
+}
+
diff --git a/global.sym b/global.sym
index 5fccbc58a9..f17db24143 100644
--- a/global.sym
+++ b/global.sym
@@ -430,6 +430,7 @@ Perl_scan_oct
 Perl_screaminstr
 Perl_share_hek
 Perl_csighandler
+Perl_csighandler
 Perl_stack_grow
 Perl_start_subparse
 Perl_sv_2bool
diff --git a/iperlsys.h b/iperlsys.h
index f84852de16..8380c5ba77 100644
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -51,7 +51,11 @@
 #include "perlio.h"
 
 #ifndef Sighandler_t
+#  if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+typedef Signal_t (*Sighandler_t) (int, ...);
+#  else
 typedef Signal_t (*Sighandler_t) (int);
+#  endif
 #endif
 
 #if defined(PERL_IMPLICIT_SYS)
diff --git a/mg.c b/mg.c
index 78ccb9a113..f4f8f60f4f 100644
--- a/mg.c
+++ b/mg.c
@@ -52,7 +52,11 @@ tie.
 #  include <sys/pstat.h>
 #endif
 
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Signal_t Perl_csighandler(int sig, ...);
+#else
 Signal_t Perl_csighandler(int sig);
+#endif
 
 #ifdef __Lynx__
 /* Missing protos on LynxOS */
@@ -1184,7 +1188,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
     	    if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
 #endif
     	    /* cache state so we don't fetch it again */
-    	    if(sigstate == SIG_IGN)
+    	    if(sigstate == (Sighandler_t) SIG_IGN)
     	    	sv_setpv(sv,"IGNORE");
     	    else
     	    	sv_setsv(sv,&PL_sv_undef);
@@ -1241,7 +1245,7 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
 	    PL_sig_defaulting[i] = 1;
 	    (void)rsignal(i, PL_csighandlerp);
 #else
-	    (void)rsignal(i, SIG_DFL);
+	    (void)rsignal(i, (Sighandler_t) SIG_DFL);
 #endif
     	    if(PL_psig_name[i]) {
     		SvREFCNT_dec(PL_psig_name[i]);
@@ -1270,7 +1274,11 @@ S_raise_signal(pTHX_ int sig)
 }
 
 Signal_t
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Perl_csighandler(int sig, ...)
+#else
 Perl_csighandler(int sig)
+#endif
 {
 #ifdef PERL_GET_SIG_CONTEXT
     dTHXa(PERL_GET_SIG_CONTEXT);
@@ -1419,7 +1427,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	    PL_sig_ignoring[i] = 1;
 	    (void)rsignal(i, PL_csighandlerp);
 #else
-	    (void)rsignal(i, SIG_IGN);
+	    (void)rsignal(i, (Sighandler_t) SIG_IGN);
 #endif
 	}
     }
@@ -1431,7 +1439,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	    (void)rsignal(i, PL_csighandlerp);
 	  }
 #else
-	    (void)rsignal(i, SIG_DFL);
+	    (void)rsignal(i, (Sighandler_t) SIG_DFL);
 #endif
     }
     else {
@@ -2613,7 +2621,7 @@ Perl_whichsig(pTHX_ const char *sig)
 }
 
 Signal_t
-Perl_sighandler(int sig)
+Perl_sighandler(int sig, ...)
 {
 #ifdef PERL_GET_SIG_CONTEXT
     dTHXa(PERL_GET_SIG_CONTEXT);
@@ -2683,6 +2691,36 @@ Perl_sighandler(int sig)
     PUSHSTACKi(PERLSI_SIGNAL);
     PUSHMARK(SP);
     PUSHs(sv);
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+    {
+	 struct sigaction oact;
+
+	 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
+	      siginfo_t *sip;
+	      va_list args;
+
+	      va_start(args, sig);
+	      sip = (siginfo_t*)va_arg(args, siginfo_t*);
+	      if (sip) {
+		   HV *sih = newHV();
+		   SV *rv  = newRV_noinc((SV*)sih);
+		   /* The siginfo fields signo, code, errno, pid, uid,
+		    * addr, status, and band are defined by POSIX/SUSv3. */
+		   hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
+		   hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
+		   hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
+		   hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
+		   hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
+		   hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
+		   hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
+		   hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
+		   EXTEND(SP, 2);
+		   PUSHs((SV*)rv);
+		   PUSHs(newSVpv((void*)sip, sizeof(*sip)));
+	      }
+	 }
+    }
+#endif
     PUTBACK;
 
     call_sv((SV*)cv, G_DISCARD|G_EVAL);
diff --git a/perl.c b/perl.c
index 4884865f28..3ff4a80eec 100644
--- a/perl.c
+++ b/perl.c
@@ -258,7 +258,7 @@ perl_construct(pTHXx)
 	    SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
 	}
 
-	PL_sighandlerp = Perl_sighandler;
+	PL_sighandlerp = (Sighandler_t) Perl_sighandler;
 	PL_pidstatus = newHV();
     }
 
@@ -2001,7 +2001,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #  define SIGCHLD SIGCLD
 #endif
 	Sighandler_t sigstate = rsignal_state(SIGCHLD);
-	if (sigstate == SIG_IGN) {
+	if (sigstate == (Sighandler_t) SIG_IGN) {
 	    if (ckWARN(WARN_SIGNAL))
 		Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
 			    "Can't ignore signal CHLD, forcing to default");
diff --git a/perl.h b/perl.h
index 9560689723..63eba706a1 100644
--- a/perl.h
+++ b/perl.h
@@ -2404,7 +2404,7 @@ typedef struct clone_params CLONE_PARAMS;
 #    define PERL_FPU_INIT fpsetmask(0);
 #  else
 #    if defined(SIGFPE) && defined(SIG_IGN) && !defined(PERL_MICRO)
-#      define PERL_FPU_INIT       PL_sigfpe_saved = signal(SIGFPE, SIG_IGN);
+#      define PERL_FPU_INIT       PL_sigfpe_saved = (Sighandler_t) signal(SIGFPE, SIG_IGN);
 #      define PERL_FPU_PRE_EXEC   { Sigsave_t xfpe; rsignal_save(SIGFPE, PL_sigfpe_saved, &xfpe);
 #      define PERL_FPU_POST_EXEC    rsignal_restore(SIGFPE, &xfpe); }
 #    else
diff --git a/pp_sys.c b/pp_sys.c
index 0ce6f43dd0..77613cb288 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4240,8 +4240,8 @@ PP(pp_system)
 	    if (did_pipes)
 		PerlLIO_close(pp[1]);
 #ifndef PERL_MICRO
-	    rsignal_save(SIGINT, SIG_IGN, &ihand);
-	    rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+	    rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
+	    rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
 #endif
 	    do {
 		result = wait4pid(childpid, &status, 0);
diff --git a/proto.h b/proto.h
index 888c991102..522ee03fe2 100644
--- a/proto.h
+++ b/proto.h
@@ -1655,8 +1655,13 @@ PERL_CALLCONV void	Perl_setdefout(pTHX_ GV* gv);
 PERL_CALLCONV HEK*	Perl_share_hek(pTHX_ const char* str, I32 len, U32 hash)
 			__attribute__nonnull__(pTHX_1);
 
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+PERL_CALLCONV Signal_t	Perl_sighandler(int sig, ...);
+PERL_CALLCONV Signal_t	Perl_csighandler(int sig, ...);
+#else
 PERL_CALLCONV Signal_t	Perl_sighandler(int sig);
 PERL_CALLCONV Signal_t	Perl_csighandler(int sig);
+#endif
 PERL_CALLCONV SV**	Perl_stack_grow(pTHX_ SV** sp, SV**p, int n)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
diff --git a/util.c b/util.c
index 4f1a8e89da..3635d352f2 100644
--- a/util.c
+++ b/util.c
@@ -2413,10 +2413,10 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
 #endif
 
-    act.sa_handler = handler;
+    act.sa_handler = (void(*)(int))handler;
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
@@ -2424,13 +2424,13 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
         act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
-    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+    if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
 	act.sa_flags |= SA_NOCLDWAIT;
 #endif
     if (sigaction(signo, &act, &oact) == -1)
-    	return SIG_ERR;
+    	return (Sighandler_t) SIG_ERR;
     else
-    	return oact.sa_handler;
+    	return (Sighandler_t) oact.sa_handler;
 }
 
 Sighandler_t
@@ -2439,9 +2439,9 @@ Perl_rsignal_state(pTHX_ int signo)
     struct sigaction oact;
 
     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
     else
-	return oact.sa_handler;
+	return (Sighandler_t) oact.sa_handler;
 }
 
 int
@@ -2456,7 +2456,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 	return -1;
 #endif
 
-    act.sa_handler = handler;
+    act.sa_handler = (void(*)(int))handler;
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
@@ -2464,7 +2464,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
         act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
-    if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+    if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
 	act.sa_flags |= SA_NOCLDWAIT;
 #endif
     return sigaction(signo, &act, save);
@@ -2491,7 +2491,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 #if defined(USE_ITHREADS) && !defined(WIN32)
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
 #endif
 
     return PerlProc_signal(signo, handler);
@@ -2514,7 +2514,7 @@ Perl_rsignal_state(pTHX_ int signo)
 #if defined(USE_ITHREADS) && !defined(WIN32)
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
-	return SIG_ERR;
+	return (Sighandler_t) SIG_ERR;
 #endif
 
     PL_sig_trapped = 0;
@@ -2534,7 +2534,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 	return -1;
 #endif
     *save = PerlProc_signal(signo, handler);
-    return (*save == SIG_ERR) ? -1 : 0;
+    return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
 }
 
 int
@@ -2545,7 +2545,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
     if (PL_curinterp != aTHX)
 	return -1;
 #endif
-    return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
+    return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
 }
 
 #endif /* !HAS_SIGACTION */
@@ -2588,9 +2588,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
 #ifndef PERL_MICRO
-    rsignal_save(SIGHUP, SIG_IGN, &hstat);
-    rsignal_save(SIGINT, SIG_IGN, &istat);
-    rsignal_save(SIGQUIT, SIG_IGN, &qstat);
+    rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
+    rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
+    rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
 #endif
     do {
 	pid2 = wait4pid(pid, &status, 0);