# endif
#endif
+/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
+#if !defined(HAS_SIGACTION) && defined(VMS)
+# define FAKE_PERSISTENT_SIGNAL_HANDLERS
+#endif
+
static void restore_magic(pTHX_ void *p);
static void unwind_handler_stack(pTHX_ void *p);
#endif
break;
case '\005': /* ^E */
+ if (*(mg->mg_ptr+1) == '\0') {
#ifdef MACOS_TRADITIONAL
- {
- char msg[256];
+ {
+ char msg[256];
- sv_setnv(sv,(double)gMacPerl_OSErr);
- sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
- }
+ sv_setnv(sv,(double)gMacPerl_OSErr);
+ sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
+ }
#else
#ifdef VMS
- {
-# include <descrip.h>
-# include <starlet.h>
- char msg[255];
- $DESCRIPTOR(msgdsc,msg);
- sv_setnv(sv,(NV) vaxc$errno);
- if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
- sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
- else
- sv_setpv(sv,"");
- }
+ {
+# include <descrip.h>
+# include <starlet.h>
+ char msg[255];
+ $DESCRIPTOR(msgdsc,msg);
+ sv_setnv(sv,(NV) vaxc$errno);
+ if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
+ sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
+ else
+ sv_setpv(sv,"");
+ }
#else
#ifdef OS2
- if (!(_emx_env & 0x200)) { /* Under DOS */
- sv_setnv(sv, (NV)errno);
- sv_setpv(sv, errno ? Strerror(errno) : "");
- } else {
- if (errno != errno_isOS2) {
- int tmp = _syserrno();
- if (tmp) /* 2nd call to _syserrno() makes it 0 */
- Perl_rc = tmp;
- }
- sv_setnv(sv, (NV)Perl_rc);
- sv_setpv(sv, os2error(Perl_rc));
- }
+ if (!(_emx_env & 0x200)) { /* Under DOS */
+ sv_setnv(sv, (NV)errno);
+ sv_setpv(sv, errno ? Strerror(errno) : "");
+ } else {
+ if (errno != errno_isOS2) {
+ int tmp = _syserrno();
+ if (tmp) /* 2nd call to _syserrno() makes it 0 */
+ Perl_rc = tmp;
+ }
+ sv_setnv(sv, (NV)Perl_rc);
+ sv_setpv(sv, os2error(Perl_rc));
+ }
#else
#ifdef WIN32
- {
- DWORD dwErr = GetLastError();
- sv_setnv(sv, (NV)dwErr);
- if (dwErr)
- {
- PerlProc_GetOSError(sv, dwErr);
- }
- else
- sv_setpv(sv, "");
- SetLastError(dwErr);
- }
+ {
+ DWORD dwErr = GetLastError();
+ sv_setnv(sv, (NV)dwErr);
+ if (dwErr)
+ {
+ PerlProc_GetOSError(sv, dwErr);
+ }
+ else
+ sv_setpv(sv, "");
+ SetLastError(dwErr);
+ }
#else
- sv_setnv(sv, (NV)errno);
- sv_setpv(sv, errno ? Strerror(errno) : "");
+ sv_setnv(sv, (NV)errno);
+ sv_setpv(sv, errno ? Strerror(errno) : "");
#endif
#endif
#endif
#endif
- SvNOK_on(sv); /* what a wonderful hack! */
- break;
+ SvNOK_on(sv); /* what a wonderful hack! */
+ }
+ else if (strEQ(mg->mg_ptr+1, "NCODING"))
+ sv_setsv(sv, PL_encoding);
+ break;
case '\006': /* ^F */
sv_setiv(sv, (IV)PL_maxsysfd);
break;
case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
if (*(mg->mg_ptr+1) == '\0')
sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
- else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) {
+ else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
if (PL_compiling.cop_warnings == pWARN_NONE ||
PL_compiling.cop_warnings == pWARN_STD)
{
}
SvPOK_only(sv);
}
- else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
+ else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
sv_setiv(sv, (IV)PL_widesyscalls);
break;
case '1': case '2': case '3': case '4':
#if defined(VMS) || defined(EPOC)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
-# ifdef PERL_IMPLICIT_SYS
+# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
PerlEnv_clearenv();
# else
-# ifdef WIN32
- char *envv = GetEnvironmentStrings();
- char *cur = envv;
- STRLEN len;
- while (*cur) {
- char *end = strchr(cur,'=');
- if (end && end != cur) {
- *end = '\0';
- my_setenv(cur,Nullch);
- *end = '=';
- cur = end + strlen(end+1)+2;
- }
- else if ((len = strlen(cur)))
- cur += len+1;
- }
- FreeEnvironmentStrings(envv);
-# else
-#ifdef USE_ENVIRON_ARRAY
+# ifdef USE_ENVIRON_ARRAY
# ifndef PERL_USE_SAFE_PUTENV
I32 i;
environ[0] = Nullch;
-#endif /* USE_ENVIRON_ARRAY */
-# endif /* WIN32 */
-# endif /* PERL_IMPLICIT_SYS */
-#endif /* VMS */
+# endif /* USE_ENVIRON_ARRAY */
+# endif /* PERL_IMPLICIT_SYS || WIN32 */
+#endif /* VMS || EPC */
return 0;
}
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
+static int sig_ignoring_initted = 0;
+static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
+#endif
+
#ifndef PERL_MICRO
int
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
else {
- Sighandler_t sigstate = rsignal_state(i);
+ Sighandler_t sigstate;
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
+ if (sig_ignoring_initted && sig_ignoring[i])
+ sigstate = SIG_IGN;
+ else
+#endif
+ sigstate = rsignal_state(i);
/* cache state so we don't fetch it again */
if(sigstate == SIG_IGN)
Signal_t
Perl_csighandler(int sig)
{
+#ifndef PERL_OLD_SIGNALS
+ dTHX;
+#endif
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
+ (void) rsignal(sig, &Perl_csighandler);
+ if (sig_ignoring[sig]) return;
+#endif
#ifdef PERL_OLD_SIGNALS
/* Call the perl level handler now with risk we may be in malloc() etc. */
(*PL_sighandlerp)(sig);
#else
- dTHX;
Perl_raise_signal(aTHX_ sig);
#endif
}
Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s);
return 0;
}
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
+ if (!sig_ignoring_initted) {
+ int j;
+ for (j = 0; j < SIG_SIZE; j++) sig_ignoring[j] = 0;
+ sig_ignoring_initted = 1;
+ }
+ sig_ignoring[i] = 0;
+#endif
SvREFCNT_dec(PL_psig_name[i]);
SvREFCNT_dec(PL_psig_ptr[i]);
PL_psig_ptr[i] = SvREFCNT_inc(sv);
}
s = SvPV_force(sv,len);
if (strEQ(s,"IGNORE")) {
- if (i)
+ if (i) {
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
+ sig_ignoring[i] = 1;
+ (void)rsignal(i, &Perl_csighandler);
+#else
(void)rsignal(i, SIG_IGN);
- else
+#endif
+ } else
*svp = 0;
}
else if (strEQ(s,"DEFAULT") || !*s) {
DEBUG_x(dump_all());
break;
case '\005': /* ^E */
+ if (*(mg->mg_ptr+1) == '\0') {
#ifdef MACOS_TRADITIONAL
- gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
#else
# ifdef VMS
- set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
# else
# ifdef WIN32
- SetLastError( SvIV(sv) );
+ SetLastError( SvIV(sv) );
# else
# ifdef OS2
- os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
# else
- /* will anyone ever use this? */
- SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
+ /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
# endif
# endif
# endif
#endif
- break;
+ }
+ else if (strEQ(mg->mg_ptr+1, "NCODING")) {
+ if (PL_encoding)
+ sv_setsv(PL_encoding, sv);
+ else
+ PL_encoding = newSVsv(sv);
+ }
case '\006': /* ^F */
PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
| (i ? G_WARN_ON : G_WARN_OFF) ;
}
}
- else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) {
+ else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
if (!SvPOK(sv) && PL_localizing) {
sv_setpvn(sv, WARN_NONEstring, WARNsize);
}
}
}
- else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
+ else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
PL_widesyscalls = SvTRUE(sv);
break;
case '.':
return 0;
}
+#if !defined(PERL_IMPLICIT_CONTEXT)
static SV* sig_sv;
+#endif
Signal_t
Perl_sighandler(int sig)
if(PL_psig_name[sig]) {
sv = SvREFCNT_inc(PL_psig_name[sig]);
flags |= 64;
+#if !defined(PERL_IMPLICIT_CONTEXT)
sig_sv = sv;
+#endif
} else {
sv = sv_newmortal();
sv_setpv(sv,PL_sig_name[sig]);
if (flags & 1)
PL_savestack_ix -= 5; /* Unprotect save in progress. */
/* cxstack_ix-- Not needed, die already unwound it. */
+#if !defined(PERL_IMPLICIT_CONTEXT)
if (flags & 64)
SvREFCNT_dec(sig_sv);
+#endif
}
projects / p5sagit/p5-mst-13.2.git / blobdiff