X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=d658bbca3307657b8f6928113cc78333dc4a7719;hb=f8babb2524be4b18ced06634d930c03291c1f313;hp=ff330269be5abb92320be2e80e9c399315d05178;hpb=11206fddaf7ef0686e22e60221d236872f9d4063;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index ff33026..d658bbc 100644
--- a/mg.c
+++ b/mg.c
@@ -272,7 +272,7 @@ Perl_mg_length(pTHX_ SV *sv)
 
     if (DO_UTF8(sv)) {
         const U8 *s = (U8*)SvPV_const(sv, len);
-        len = Perl_utf8_length(aTHX_ s, s + len);
+	len = utf8_length(s, s + len);
     }
     else
         (void)SvPV_const(sv, len);
@@ -497,9 +497,18 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
     if (PL_curpm) {
 	register const REGEXP * const rx = PM_GETRE(PL_curpm);
 	if (rx) {
-	    return mg->mg_obj
-		? rx->nparens       /* @+ */
-		: rx->lastparen;    /* @- */
+	    if (mg->mg_obj) {			/* @+ */
+		/* return the number possible */
+		return rx->nparens;
+	    } else {				/* @- */
+		I32 paren = rx->lastparen;
+
+		/* return the last filled */
+		while ( paren >= 0
+			&& (rx->startp[paren] == -1 || rx->endp[paren] == -1) )
+		    paren--;
+		return (U32)paren;
+	    }
 	}
     }
 
@@ -531,7 +540,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 		    if (i > 0 && RX_MATCH_UTF8(rx)) {
 			const char * const b = rx->subbeg;
 			if (b)
-			    i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+			    i = utf8_length((U8*)b, (U8*)(b+i));
 		    }
 
 		    sv_setiv(sv, i);
@@ -819,10 +828,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
             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 */
-		SV **bits_all;
 		HV * const bits=get_hv("warnings::Bits", FALSE);
-		if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
-		    sv_setsv(sv, *bits_all);
+		if (bits) {
+		    SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
+		    if (bits_all)
+			sv_setsv(sv, *bits_all);
 		}
 	        else {
 		    sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
@@ -853,6 +863,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 		i = t1 - s1;
 		s = rx->subbeg + s1;
 		assert(rx->subbeg);
+		assert(rx->sublen >= s1);
 
 	      getrx:
 		if (i >= 0) {
@@ -860,8 +871,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 		    TAINT_NOT;
 		    sv_setpvn(sv, s, i);
 		    PL_tainted = oldtainted;
-		    if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
+		    if ( (rx->extflags & RXf_CANY_SEEN)
+			? (RX_MATCH_UTF8(rx)
+				    && (!i || is_utf8_string((U8*)s, i)))
+			: (RX_MATCH_UTF8(rx)) )
+		    {
 			SvUTF8_on(sv);
+		    }
 		    else
 			SvUTF8_off(sv);
 		    if (PL_tainting) {
@@ -1072,8 +1088,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 	    Stat_t sbuf;
 	    int i = 0, j = 0;
 
-	    strncpy(eltbuf, s, 255);
-	    eltbuf[255] = 0;
+	    my_strlcpy(eltbuf, s, sizeof(eltbuf));
 	    elt = eltbuf;
 	    do {          /* DCL$PATH may be a search list */
 		while (1) {   /* as may dev portion of any element */
@@ -1097,16 +1112,16 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 #endif /* VMS */
 	if (s && klen == 4 && strEQ(ptr,"PATH")) {
 	    const char * const strend = s + len;
-#ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
-	    const char path_sep = '|';
-#else
-	    const char path_sep = ':';
-#endif
 
 	    while (s < strend) {
 		char tmpbuf[256];
 		Stat_t st;
 		I32 i;
+#ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
+		const char path_sep = '|';
+#else
+		const char path_sep = ':';
+#endif
 		s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
 			     s, strend, path_sep, &i);
 		s++;
@@ -1178,7 +1193,7 @@ static void
 restore_sigmask(pTHX_ SV *save_sv)
 {
     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
-    (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+    (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
 }
 #endif
 int
@@ -1224,14 +1239,12 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
 	SV** svp = NULL;
 	if (strEQ(s,"__DIE__"))
 	    svp = &PL_diehook;
-	else if (strEQ(s,"__WARN__"))
+	else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
 	    svp = &PL_warnhook;
-	else
-	    Perl_croak(aTHX_ "No such hook: %s", s);
 	if (svp && *svp) {
-            SV * const to_dec = *svp;
+	    SV *const to_dec = *svp;
 	    *svp = NULL;
-    	    SvREFCNT_dec(to_dec);
+	    SvREFCNT_dec(to_dec);
 	}
     }
     else {
@@ -1277,6 +1290,10 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+#ifndef SIG_PENDING_DIE_COUNT
+#  define SIG_PENDING_DIE_COUNT 120
+#endif
+
 static void
 S_raise_signal(pTHX_ int sig)
 {
@@ -1284,7 +1301,9 @@ S_raise_signal(pTHX_ int sig)
     /* Set a flag to say this signal is pending */
     PL_psig_pend[sig]++;
     /* And one to say _a_ signal is pending */
-    PL_sig_pending = 1;
+    if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
+	Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
+		(unsigned long)SIG_PENDING_DIE_COUNT);
 }
 
 Signal_t
@@ -1311,7 +1330,17 @@ Perl_csighandler(int sig)
             exit(1);
 #endif
 #endif
-   if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+   if (
+#ifdef SIGILL
+	   sig == SIGILL ||
+#endif
+#ifdef SIGBUS
+	   sig == SIGBUS ||
+#endif
+#ifdef SIGSEGV
+	   sig == SIGSEGV ||
+#endif
+	   (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
 	/* Call the perl level handler now--
 	 * with risk we may be in malloc() etc. */
 	(*PL_sighandlerp)(sig);
@@ -1384,7 +1413,8 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	    Perl_croak(aTHX_ "No such hook: %s", s);
 	i = 0;
 	if (*svp) {
-	    to_dec = *svp;
+	    if (*svp != PERL_WARNHOOK_FATAL)
+		to_dec = *svp;
 	    *svp = NULL;
 	}
     }
@@ -1435,7 +1465,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	    SvREFCNT_dec(to_dec);
 	return 0;
     }
-    s = SvPV_force(sv,len);
+    s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
     if (strEQ(s,"IGNORE")) {
 	if (i) {
 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
@@ -1873,8 +1903,7 @@ Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
 
     if (!SvOK(sv))
 	return 0;
-    if (SvFLAGS(sv) & SVp_SCREAM
-	&& (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
+    if (isGV_with_GP(sv)) {
 	/* We're actually already a typeglob, so don't need the stuff below.
 	 */
 	return 0;
@@ -2093,6 +2122,7 @@ Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_UNUSED_ARG(mg);
     sv_unmagic(sv, PERL_MAGIC_bm);
+    SvTAIL_off(sv);
     SvVALID_off(sv);
     return 0;
 }
@@ -2290,11 +2320,16 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 		        accumulate |= ptr[i] ;
 		        any_fatals |= (ptr[i] & 0xAA) ;
 		    }
-		    if (!accumulate)
-	                PL_compiling.cop_warnings = pWARN_NONE;
+		    if (!accumulate) {
+		        if (!specialWARN(PL_compiling.cop_warnings))
+			    PerlMemShared_free(PL_compiling.cop_warnings);
+			PL_compiling.cop_warnings = pWARN_NONE;
+		    }
 		    /* Yuck. I can't see how to abstract this:  */
 		    else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
 				       WARN_ALL) && !any_fatals) {
+			if (!specialWARN(PL_compiling.cop_warnings))
+			    PerlMemShared_free(PL_compiling.cop_warnings);
 	                PL_compiling.cop_warnings = pWARN_ALL;
 	                PL_dowarn |= G_WARN_ONCE ;
 	            }
@@ -2523,8 +2558,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
             }
             if (i)
                 (void)setgroups(i, gary);
-            if (gary)
-                Safefree(gary);
+	    Safefree(gary);
 	}
 #else  /* HAS_SETGROUPS */
 	PL_egid = SvIV(sv);
@@ -2583,15 +2617,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    setproctitle("%s", s);
 #   endif
 	}
-#endif
-#if defined(__hpux) && defined(PSTAT_SETCMD)
+#elif defined(__hpux) && defined(PSTAT_SETCMD)
 	if (PL_origalen != 1) {
 	     union pstun un;
 	     s = SvPV_const(sv, len);
 	     un.pst_command = (char *)s;
 	     pstat(PSTAT_SETCMD, un, len, 0, 0);
 	}
-#endif
+#else
 	if (PL_origalen > 1) {
 	    /* PL_origalen is set in perl_parse(). */
 	    s = SvPV_force(sv,len);
@@ -2602,20 +2635,26 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    }
 	    else {
 		/* Shorter than original, will be padded. */
+#ifdef PERL_DARWIN
+		/* Special case for Mac OS X: see [perl #38868] */
+		const int pad = 0;
+#else
+		/* Is the space counterintuitive?  Yes.
+		 * (You were expecting \0?)
+		 * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
+		 * --jhi */
+		const int pad = ' ';
+#endif
 		Copy(s, PL_origargv[0], len, char);
 		PL_origargv[0][len] = 0;
 		memset(PL_origargv[0] + len + 1,
-		       /* Is the space counterintuitive?  Yes.
-			* (You were expecting \0?)  
-			* Does it work?  Seems to.  (In Linux 2.4.20 at least.)
-			* --jhi */
-		       (int)' ',
-		       PL_origalen - len - 1);
+		       pad,  PL_origalen - len - 1);
 	    }
 	    PL_origargv[0][PL_origalen-1] = 0;
 	    for (i = 1; i < PL_origargc; i++)
 		PL_origargv[i] = 0;
 	}
+#endif
 	UNLOCK_DOLLARZERO_MUTEX;
 	break;
 #endif
@@ -2745,7 +2784,7 @@ Perl_sighandler(int sig)
 #endif
 		   EXTEND(SP, 2);
 		   PUSHs((SV*)rv);
-		   PUSHs(newSVpv((void*)sip, sizeof(*sip)));
+		   PUSHs(newSVpv((char *)sip, sizeof(*sip)));
 	      }
 
               va_end(args);
@@ -2820,10 +2859,10 @@ S_restore_magic(pTHX_ const void *p)
 	    /* 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 );
+	    const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
+	    if (pubflags) {
+		SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
+		SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
 	    }
 	}
     }
@@ -2907,6 +2946,8 @@ int
 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
+    PERL_UNUSED_ARG(sv);
+
     assert(mg->mg_len == HEf_SVKEY);
 
     PERL_UNUSED_ARG(sv);