X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=46b2d7500089adafbbc28bd40c98e248597481b7;hb=d1ca9ea32e7b8d5812a70687974b0e642057ff99;hp=dcc3a90c2480eabcb0d5a16876b51193fce0c997;hpb=e15faf7d09c73a41f95fbe6a0045ad5b17c899a6;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index dcc3a90..46b2d75 100644
--- a/mg.c
+++ b/mg.c
@@ -52,7 +52,11 @@ tie.
 #  include <sys/pstat.h>
 #endif
 
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Signal_t Perl_csighandler(int sig, ...);
+#else
 Signal_t Perl_csighandler(int sig);
+#endif
 
 #ifdef __Lynx__
 /* Missing protos on LynxOS */
@@ -781,11 +785,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	if (*(mg->mg_ptr+1) == '\0')
 	    sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 	else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
-	    if (PL_compiling.cop_warnings == pWARN_NONE ||
-	        PL_compiling.cop_warnings == pWARN_STD)
-	    {
+	    if (PL_compiling.cop_warnings == pWARN_NONE) {
 	        sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
-            }
+	    }
+	    else if (PL_compiling.cop_warnings == pWARN_STD) {
+		sv_setpvn(
+		    sv, 
+		    (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
+		    WARNsize
+		);
+	    }
             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 		/* Get the bit mask for $warnings::Bits{all}, because
 		 * it could have been extended by warnings::register */
@@ -1041,10 +1050,13 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 	MgTAINTEDDIR_off(mg);
 #ifdef VMS
 	if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
-	    char pathbuf[256], eltbuf[256], *cp, *elt = s;
+	    char pathbuf[256], eltbuf[256], *cp, *elt;
 	    Stat_t sbuf;
 	    int i = 0, j = 0;
 
+	    strncpy(eltbuf, s, 255);
+	    eltbuf[255] = 0;
+	    elt = eltbuf;
 	    do {          /* DCL$PATH may be a search list */
 		while (1) {   /* as may dev portion of any element */
 		    if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
@@ -1184,7 +1196,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
     	    if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
 #endif
     	    /* cache state so we don't fetch it again */
-    	    if(sigstate == SIG_IGN)
+    	    if(sigstate == (Sighandler_t) SIG_IGN)
     	    	sv_setpv(sv,"IGNORE");
     	    else
     	    	sv_setsv(sv,&PL_sv_undef);
@@ -1241,7 +1253,7 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
 	    PL_sig_defaulting[i] = 1;
 	    (void)rsignal(i, PL_csighandlerp);
 #else
-	    (void)rsignal(i, SIG_DFL);
+	    (void)rsignal(i, (Sighandler_t) SIG_DFL);
 #endif
     	    if(PL_psig_name[i]) {
     		SvREFCNT_dec(PL_psig_name[i]);
@@ -1270,7 +1282,11 @@ S_raise_signal(pTHX_ int sig)
 }
 
 Signal_t
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Perl_csighandler(int sig, ...)
+#else
 Perl_csighandler(int sig)
+#endif
 {
 #ifdef PERL_GET_SIG_CONTEXT
     dTHXa(PERL_GET_SIG_CONTEXT);
@@ -1419,7 +1435,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	    PL_sig_ignoring[i] = 1;
 	    (void)rsignal(i, PL_csighandlerp);
 #else
-	    (void)rsignal(i, SIG_IGN);
+	    (void)rsignal(i, (Sighandler_t) SIG_IGN);
 #endif
 	}
     }
@@ -1431,7 +1447,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	    (void)rsignal(i, PL_csighandlerp);
 	  }
 #else
-	    (void)rsignal(i, SIG_DFL);
+	    (void)rsignal(i, (Sighandler_t) SIG_DFL);
 #endif
     }
     else {
@@ -1913,7 +1929,7 @@ int
 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_UNUSED_ARG(sv);
-    TAINT_IF(mg->mg_len & 1);
+    TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
     return 0;
 }
 
@@ -1921,10 +1937,13 @@ int
 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_UNUSED_ARG(sv);
-    if (PL_tainted)
-	mg->mg_len |= 1;
-    else
-	mg->mg_len &= ~1;
+    /* update taint status unless we're restoring at scope exit */
+    if (PL_localizing != 2) {
+	if (PL_tainted)
+	    mg->mg_len |= 1;
+	else
+	    mg->mg_len &= ~1;
+    }
     return 0;
 }
 
@@ -2017,7 +2036,7 @@ Perl_vivify_defelem(pTHX_ SV *sv)
 	if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
 	    LvTARG(sv) = Nullsv;	/* array can't be extended */
 	else {
-	    SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
+	    SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
 	    if (!svp || (value = *svp) == &PL_sv_undef)
 		Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
 	}
@@ -2058,7 +2077,7 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
 		} else {
 		    Perl_croak(aTHX_
 			       "panic: magic_killbackrefs (flags=%"UVxf")",
-			       SvFLAGS(referrer));
+			       (UV)SvFLAGS(referrer));
 		}
 
 		*svp = Nullsv;
@@ -2215,19 +2234,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
 	break;
     case '\011':	/* ^I */ /* NOT \t in EBCDIC */
-	if (PL_inplace)
-	    Safefree(PL_inplace);
-	if (SvOK(sv))
-	    PL_inplace = savesvpv(sv);
-	else
-	    PL_inplace = Nullch;
+	Safefree(PL_inplace);
+	PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
 	break;
     case '\017':	/* ^O */
 	if (*(mg->mg_ptr+1) == '\0') {
-	    if (PL_osname) {
-		Safefree(PL_osname);
-		PL_osname = Nullch;
-	    }
+	    Safefree(PL_osname);
+	    PL_osname = Nullch;
 	    if (SvOK(sv)) {
 		TAINT_PROPER("assigning to $^O");
 		PL_osname = savesvpv(sv);
@@ -2616,7 +2629,11 @@ Perl_whichsig(pTHX_ const char *sig)
 }
 
 Signal_t
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Perl_sighandler(int sig, ...)
+#else
 Perl_sighandler(int sig)
+#endif
 {
 #ifdef PERL_GET_SIG_CONTEXT
     dTHXa(PERL_GET_SIG_CONTEXT);
@@ -2686,6 +2703,38 @@ Perl_sighandler(int sig)
     PUSHSTACKi(PERLSI_SIGNAL);
     PUSHMARK(SP);
     PUSHs(sv);
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+    {
+	 struct sigaction oact;
+
+	 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
+	      siginfo_t *sip;
+	      va_list args;
+
+	      va_start(args, sig);
+	      sip = (siginfo_t*)va_arg(args, siginfo_t*);
+	      if (sip) {
+		   HV *sih = newHV();
+		   SV *rv  = newRV_noinc((SV*)sih);
+		   /* The siginfo fields signo, code, errno, pid, uid,
+		    * addr, status, and band are defined by POSIX/SUSv3. */
+		   hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
+		   hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
+#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
+		   hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
+		   hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
+		   hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
+		   hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
+		   hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
+		   hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
+#endif
+		   EXTEND(SP, 2);
+		   PUSHs((SV*)rv);
+		   PUSHs(newSVpv((void*)sip, sizeof(*sip)));
+	      }
+	 }
+    }
+#endif
     PUTBACK;
 
     call_sv((SV*)cv, G_DISCARD|G_EVAL);
@@ -2708,7 +2757,7 @@ Perl_sighandler(int sig)
 	(void)rsignal(sig, PL_csighandlerp);
 #endif
 #endif /* !PERL_MICRO */
-	DieNull;
+	Perl_die(aTHX_ Nullch);
     }
 cleanup:
     if (flags & 1)
@@ -2749,8 +2798,16 @@ S_restore_magic(pTHX_ const void *p)
 	    SvFLAGS(sv) |= mgs->mgs_flags;
 	else
 	    mg_magical(sv);
-	if (SvGMAGICAL(sv))
-	    SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+	if (SvGMAGICAL(sv)) {
+	    /* downgrade public flags to private,
+	       and discard any other private flags */
+
+	    U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
+	    if (public) {
+		SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
+		SvFLAGS(sv) |= ( public << PRIVSHIFT );
+	    }
+	}
     }
 
     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */