PERL_SIGNALS=unsafe enables the old unsafe/immediate signals.

p4raw-id: //depot/perl@18766

diff --git a/embedvar.h b/embedvar.h
index b041639..afb5368 100644 (file)
--- 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 f24f094..fe54f77 100644 (file)
--- 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 81e1ac6..792d22f 100644 (file)
--- 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 866c9a8..e603ffc 100644 (file)
--- 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 ccc82da..d03809a 100644 (file)
--- 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 8c59189..e64253e 100644 (file)
--- 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 f55bdff..b743d4d 100644 (file)
--- 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 0f5bd35..b9adb9b 100644 (file)
--- 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 b14dd77..179bbc8 100644 (file)
--- 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 303a19f..e74fe71 100644 (file)
--- 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)