PERL_SIGNALS=unsafe enables the old unsafe/immediate signals.

p4raw-id: //depot/perl@18766

10 files changed, 58 insertions, 32 deletions

diff --git a/embedvar.h b/embedvar.h
index b0416392f0..afb53681ca 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -369,6 +369,7 @@
 #define PL_sh_path		(vTHX->Ish_path)
 #define PL_sig_pending		(vTHX->Isig_pending)
 #define PL_sighandlerp		(vTHX->Isighandlerp)
+#define PL_signals		(vTHX->Isignals)
 #define PL_sort_RealCmp		(vTHX->Isort_RealCmp)
 #define PL_splitstr		(vTHX->Isplitstr)
 #define PL_srand_called		(vTHX->Isrand_called)
@@ -660,6 +661,7 @@
 #define PL_Ish_path		PL_sh_path
 #define PL_Isig_pending		PL_sig_pending
 #define PL_Isighandlerp		PL_sighandlerp
+#define PL_Isignals		PL_signals
 #define PL_Isort_RealCmp	PL_sort_RealCmp
 #define PL_Isplitstr		PL_splitstr
 #define PL_Isrand_called	PL_srand_called
diff --git a/intrpvar.h b/intrpvar.h
index f24f0940dd..fe54f7770e 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -498,6 +498,8 @@ PERLVARI(Iin_load_module, int, 0)	/* to prevent recursions in PerlIO_find_layer
 
 PERLVAR(Iunicode, U32)	/* Unicode features: $ENV{PERL_UNICODE} or -C */
 
+PERLVAR(Isignals, U32)	/* Using which pre-5.8 signals */
+
 /* New variables must be added to the very end, before this comment,
  * for binary compatibility (the offsets of the old members must not change).
  * XSUB.h provides wrapper functions via perlapi.h that make this
diff --git a/mg.c b/mg.c
index 81e1ac618d..792d22fded 100644
--- a/mg.c
+++ b/mg.c
@@ -640,7 +640,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	sv_setiv(sv, (IV)PL_perldb);
 	break;
     case '\023':		/* ^S */
-	{
+        if (*(mg->mg_ptr+1) == '\0') {
 	    if (PL_lex_state != LEX_NOTPARSING)
 		(void)SvOK_off(sv);
 	    else if (PL_in_eval)
@@ -1122,13 +1122,12 @@ Perl_csighandler(int sig)
             exit(1);
 #endif
 #endif
-
-#ifdef PERL_OLD_SIGNALS
-    /* Call the perl level handler now with risk we may be in malloc() etc. */
-    (*PL_sighandlerp)(sig);
-#else
-    Perl_raise_signal(aTHX_ sig);
-#endif
+   if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+	/* Call the perl level handler now--
+	 * with risk we may be in malloc() etc. */
+	(*PL_sighandlerp)(sig);
+   else
+	Perl_raise_signal(aTHX_ sig);
 }
 
 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
diff --git a/perl.c b/perl.c
index 866c9a8826..e603ffc18e 100644
--- a/perl.c
+++ b/perl.c
@@ -1394,6 +1394,15 @@ print \"  \\@INC:\\n    @INC\\n\";");
 	 }
     }
 
+    if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
+	 if (strEQ(s, "unsafe"))
+	      PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
+	 else if (strEQ(s, "safe"))
+	      PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
+	 else
+	      Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
+    }
+
     init_lexer();
 
     /* now parse the script */
diff --git a/perl.h b/perl.h
index ccc82da79d..d03809aef1 100644
--- a/perl.h
+++ b/perl.h
@@ -3868,11 +3868,9 @@ typedef struct am_table_short AMTS;
  */
 
 #ifndef PERL_MICRO
-#   ifndef PERL_OLD_SIGNALS
-#		ifndef PERL_ASYNC_CHECK
-#			define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
-#		endif
-#   endif
+#	ifndef PERL_ASYNC_CHECK
+#		define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+#	endif
 #endif
 
 #ifndef PERL_ASYNC_CHECK
@@ -4201,6 +4199,8 @@ extern void moncontrol(int);
 #define PERL_UNICODE_LOCALE			'L'
 #define PERL_UNICODE_WIDESYSCALLS		'W'
 
+#define PERL_SIGNALS_UNSAFE_FLAG	0x0001
+
 /* and finally... */
 #define PERL_PATCHLEVEL_H_IMPLICIT
 #include "patchlevel.h"
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8c59189c71..e64253e559 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3427,6 +3427,10 @@ superfluous.
 (W signal) The signal handler named in %SIG doesn't, in fact, exist.
 Perhaps you put it into the wrong package?
 
+=item PERL_SIGNALS illegal: "%s"
+
+See L<perlrun/PERL_SIGNALS> for legal values.
+
 =item sort is now a reserved word
 
 (F) An ancient error message that almost nobody ever runs into anymore.
diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index f55bdff505..b743d4df04 100644
--- a/pod/perlipc.pod
+++ b/pod/perlipc.pod
@@ -279,7 +279,7 @@ to find out whether anyone (or anything) has accidentally removed our fifo.
 	sleep 2;    # to avoid dup signals
     }
 
-=head2 Deferred Signals
+=head2 Deferred Signals (Safe signals)
 
 In Perls before Perl 5.7.3 by installing Perl code to deal with
 signals, you were exposing yourself to danger from two things.  First,
@@ -368,6 +368,10 @@ there are un-waited-for completed child processes.
 
 =back
 
+If you want the old signal behaviour back regardless of possible
+memory corruption, set the environment variable C<PERL_SIGNALS> to
+C<"unsafe">.
+
 =head1 Using open() for IPC
 
 Perl's basic open() statement can also be used for unidirectional
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 0f5bd35ffd..b9adb9b5a0 100644
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -1091,6 +1091,12 @@ affect perl on VMS include PERLSHR, PERL_ENV_TABLES, and
 SYS$TIMEZONE_DIFFERENTIAL but are optional and discussed further in
 L<perlvms> and in F<README.vms> in the Perl source distribution.
 
+=item PERL_SIGNALS
+
+In Perls 5.8.1 and later.  If set to C<unsafe> the pre-Perl-5.8.0
+signals behaviour (immediate but unsafe) is restored.  If set to
+C<safe> the safe signals are used.
+
 =item PERL_UNICODE
 
 Equivalent to the B<-C> command-line switch.
diff --git a/pp_sys.c b/pp_sys.c
index b14dd7719e..179bbc845e 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3963,13 +3963,14 @@ PP(pp_wait)
     Pid_t childpid;
     int argflags;
 
-#ifdef PERL_OLD_SIGNALS
-    childpid = wait4pid(-1, &argflags, 0);
-#else
-    while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
-	PERL_ASYNC_CHECK();
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        childpid = wait4pid(-1, &argflags, 0);
+    else {
+        while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
+	       errno == EINTR) {
+	  PERL_ASYNC_CHECK();
+	}
     }
-#endif
 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
@@ -3993,13 +3994,14 @@ PP(pp_waitpid)
 
     optype = POPi;
     childpid = TOPi;
-#ifdef PERL_OLD_SIGNALS
-    childpid = wait4pid(childpid, &argflags, optype);
-#else
-    while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
-	PERL_ASYNC_CHECK();
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        childpid = wait4pid(childpid, &argflags, optype);
+    else {
+        while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 &&
+	       errno == EINTR) {
+	  PERL_ASYNC_CHECK();
+	}
     }
-#endif
 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
     STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
diff --git a/util.c b/util.c
index 303a19fde3..e74fe719c4 100644
--- a/util.c
+++ b/util.c
@@ -2192,9 +2192,8 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
-#if defined(PERL_OLD_SIGNALS)
-    act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
-#endif
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #ifdef SA_NOCLDWAIT
     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
@@ -2232,9 +2231,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
-#if defined(PERL_OLD_SIGNALS)
-    act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
-#endif
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #ifdef SA_NOCLDWAIT
     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)