From: Jarkko Hietaniemi Date: Mon, 24 Feb 2003 20:04:36 +0000 (+0000) Subject: PERL_SIGNALS=unsafe enables the old unsafe/immediate signals. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4ffa73a366885f682ceccdeee45e43075e0c312e;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 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 --- 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 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 --- 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 and in F in the Perl source distribution. +=item PERL_SIGNALS + +In Perls 5.8.1 and later. If set to C the pre-Perl-5.8.0 +signals behaviour (immediate but unsafe) is restored. If set to +C 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 --- 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 --- 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)