Safe signals via POSIX::sigaction

Message-ID: <20030709054910.GH2021@perlsupport.com>

p4raw-id: //depot/perl@20081

7 files changed, 77 insertions, 13 deletions

diff --git a/embed.fnc b/embed.fnc
index b8b3252294..704f8d53f4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -689,6 +689,7 @@ p	|I32	|setenv_getix	|char* nam
 p	|void	|setdefout	|GV* gv
 p	|HEK*	|share_hek	|const char* sv|I32 len|U32 hash
 np	|Signal_t |sighandler	|int sig
+np	|Signal_t |csighandler	|int sig
 Ap	|SV**	|stack_grow	|SV** sp|SV**p|int n
 Ap	|I32	|start_subparse	|I32 is_format|U32 flags
 p	|void	|sub_crush_depth|CV* cv
diff --git a/embed.h b/embed.h
index e872a31d74..951ff7b334 100644
--- a/embed.h
+++ b/embed.h
@@ -958,6 +958,9 @@
 #ifdef PERL_CORE
 #define sighandler		Perl_sighandler
 #endif
+#ifdef PERL_CORE
+#define csighandler		Perl_csighandler
+#endif
 #define stack_grow		Perl_stack_grow
 #define start_subparse		Perl_start_subparse
 #ifdef PERL_CORE
@@ -3445,6 +3448,9 @@
 #ifdef PERL_CORE
 #define sighandler		Perl_sighandler
 #endif
+#ifdef PERL_CORE
+#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.pm b/ext/POSIX/POSIX.pm
index 74a014fb43..06e2252e81 100644
--- a/ext/POSIX/POSIX.pm
+++ b/ext/POSIX/POSIX.pm
@@ -54,7 +54,7 @@ sub AUTOLOAD {
 package POSIX::SigAction;
 
 use AutoLoader 'AUTOLOAD';
-sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0}, $_[0] }
+sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
 
 package POSIX;
 
@@ -961,3 +961,4 @@ package POSIX::SigAction;
 sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} };
 sub mask    { $_[0]->{MASK}    = $_[1] if @_ > 1; $_[0]->{MASK} };
 sub flags   { $_[0]->{FLAGS}   = $_[1] if @_ > 1; $_[0]->{FLAGS} };
+sub safe    { $_[0]->{SAFE}    = $_[1] if @_ > 1; $_[0]->{SAFE} };
diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod
index 7517a85d69..598464d3fc 100644
--- a/ext/POSIX/POSIX.pod
+++ b/ext/POSIX/POSIX.pod
@@ -1641,9 +1641,9 @@ object, it defaults to the empty set.  The third parameter contains the
 C<sa_flags>, it defaults to 0.
 
 	$sigset = POSIX::SigSet->new(SIGINT, SIGQUIT);
-	$sigaction = POSIX::SigAction->new( 'main::handler', $sigset, &POSIX::SA_NOCLDSTOP );
+	$sigaction = POSIX::SigAction->new( \&main::handler, $sigset, &POSIX::SA_NOCLDSTOP );
 
-This C<POSIX::SigAction> object should be used with the C<POSIX::sigaction()>
+This C<POSIX::SigAction> object is intended for use with the C<POSIX::sigaction()>
 function.
 
 =back
@@ -1661,6 +1661,23 @@ accessor functions to get/set the values of a SigAction object.
 	$sigset = $sigaction->mask;
 	$sigaction->flags(&POSIX::SA_RESTART);
 
+=item safe
+
+accessor function for the "safe signals" flag of a SigAction object; see
+L<perlipc> for general information on safe (a.k.a. "deferred") signals.  If
+you wish to handle a signal safely, use this accessor to set the "safe" flag
+in the C<POSIX::SigAction> object:
+
+	$sigaction->safe(1);
+
+You may also examine the "safe" flag on the output action object which is
+filled in when given as the third parameter to C<POSIX::sigaction()>:
+
+	sigaction(SIGINT, $new_action, $old_action);
+	if ($old_action->safe) {
+	    # previous SIGINT handler used safe signals
+	}
+
 =back
 
 =head2 POSIX::SigSet
diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index 11f74d46d6..379815213d 100644
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -1290,16 +1290,34 @@ sigaction(sig, optaction, oldaction = 0)
 		/* Get back the flags. */
 		svp = hv_fetch(oldaction, "FLAGS", 5, TRUE);
 		sv_setiv(*svp, oact.sa_flags);
+
+		/* Get back whether the old handler used safe signals. */
+		svp = hv_fetch(oldaction, "SAFE", 4, TRUE);
+		sv_setiv(*svp, oact.sa_handler == Perl_csighandler);
 	    }
 
 	    if (action) {
-		/* Vector new handler through %SIG.  (We always use sighandler
-		   for the C signal handler, which reads %SIG to dispatch.) */
+		/* Safe signals use "csighandler", which vectors through the
+		   PL_sighandlerp pointer when it's safe to do so.
+		   (BTW, "csighandler" is very different from "sighandler".) */
+		svp = hv_fetch(action, "SAFE", 4, FALSE);
+		act.sa_handler = (*svp && SvTRUE(*svp))
+				 ? Perl_csighandler : PL_sighandlerp;
+
+		/* Vector new Perl handler through %SIG.
+		   (The core signal handlers read %SIG to dispatch.) */
 		svp = hv_fetch(action, "HANDLER", 7, FALSE);
 		if (!svp)
 		    croak("Can't supply an action without a HANDLER");
 		sv_setsv(*sigsvp, *svp);
-		mg_set(*sigsvp);	/* handles DEFAULT and IGNORE */
+
+		/* This call actually calls sigaction() with almost the
+		   right settings, including appropriate interpretation
+		   of DEFAULT and IGNORE.  However, why are we doing
+		   this when we're about to do it again just below?  XXX */
+		mg_set(*sigsvp);
+
+		/* And here again we duplicate -- DEFAULT/IGNORE checking. */
 		if(SvPOK(*svp)) {
 			char *s=SvPVX(*svp);
 			if(strEQ(s,"IGNORE")) {
@@ -1308,12 +1326,6 @@ sigaction(sig, optaction, oldaction = 0)
 			else if(strEQ(s,"DEFAULT")) {
 				act.sa_handler = SIG_DFL;
 			}
-			else {
-				act.sa_handler = PL_sighandlerp;
-			}
-		}
-		else {
-			act.sa_handler = PL_sighandlerp;
 		}
 
 		/* Set up any desired mask. */
diff --git a/ext/POSIX/t/sigaction.t b/ext/POSIX/t/sigaction.t
index d2db20b0ff..38cde163dd 100644
--- a/ext/POSIX/t/sigaction.t
+++ b/ext/POSIX/t/sigaction.t
@@ -21,7 +21,7 @@ use vars qw/$bad7 $ok10 $bad18 $ok/;
 
 $^W=1;
 
-print "1..21\n";
+print "1..25\n";
 
 sub IGNORE {
 	$bad7=1;
@@ -155,3 +155,29 @@ if ($^O eq 'VMS') {
     kill "HUP", $$;
     print $hup21 == 1 ? "ok 21\n" : "not ok 21\n";
 }
+
+# "safe" attribute.
+# for this one, use the accessor instead of the attribute
+
+# standard signal handling via %SIG is safe
+$SIG{HUP} = \&foo;
+$oldaction = POSIX::SigAction->new;
+sigaction(SIGHUP, undef, $oldaction);
+print $oldaction->safe ? "ok 22\n" : "not ok 22\n";
+
+# SigAction handling is not safe ...
+sigaction(SIGHUP, POSIX::SigAction->new(\&foo));
+sigaction(SIGHUP, undef, $oldaction);
+print $oldaction->safe ? "not ok 23\n" : "ok 23\n";
+
+# ... unless we say so!
+$newaction = POSIX::SigAction->new(\&foo);
+$newaction->safe(1);
+sigaction(SIGHUP, $newaction);
+sigaction(SIGHUP, undef, $oldaction);
+print $oldaction->safe ? "ok 24\n" : "not ok 24\n";
+
+# And safe signal delivery must work
+$ok = 0;
+kill 'HUP', $$;
+print $ok ? "ok 25\n" : "not ok 25\n";
diff --git a/proto.h b/proto.h
index 54882c1ebb..bb91615627 100644
--- a/proto.h
+++ b/proto.h
@@ -659,6 +659,7 @@ PERL_CALLCONV I32	Perl_setenv_getix(pTHX_ char* nam);
 PERL_CALLCONV void	Perl_setdefout(pTHX_ GV* gv);
 PERL_CALLCONV HEK*	Perl_share_hek(pTHX_ const char* sv, I32 len, U32 hash);
 PERL_CALLCONV Signal_t	Perl_sighandler(int sig);
+PERL_CALLCONV Signal_t	Perl_csighandler(int sig);
 PERL_CALLCONV SV**	Perl_stack_grow(pTHX_ SV** sp, SV**p, int n);
 PERL_CALLCONV I32	Perl_start_subparse(pTHX_ I32 is_format, U32 flags);
 PERL_CALLCONV void	Perl_sub_crush_depth(pTHX_ CV* cv);