X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=0aab7868dbcb2d8329926fbd13e6f9e8785a98ae;hb=8cf8bfae8ab20c53dc9b668f5e3be813b5d11cb0;hp=95bdd374370e3430e73e9a9d2e8f61c653457f20;hpb=cf284a245bd2c9f479068768a1e22147f7925e7d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 95bdd37..0aab786 100644
--- a/util.c
+++ b/util.c
@@ -369,10 +369,9 @@ Free_t   Perl_mfree (Malloc_t where)
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 {
     register I32 tolen;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
@@ -400,10 +399,9 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons
 /* This routine was donated by Corey Satten. */
 
 char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
 {
     register I32 first;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_INSTR;
 
@@ -435,10 +433,9 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 /* same as instr but allow embedded nulls */
 
 char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 {
     PERL_ARGS_ASSERT_NINSTR;
-    PERL_UNUSED_CONTEXT;
     if (little >= lend)
         return (char*)big;
     {
@@ -462,12 +459,11 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const
 /* reverse of the above--find last substring */
 
 char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
 {
     register const char *bigbeg;
     register const I32 first = *little;
     register const char * const littleend = lend;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_RNINSTR;
 
@@ -883,11 +879,10 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
 }
 
 I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp(const char *s1, const char *s2, register I32 len)
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_IBCMP;
 
@@ -900,12 +895,11 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
 }
 
 I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
-    PERL_UNUSED_CONTEXT;
 
     PERL_ARGS_ASSERT_IBCMP_LOCALE;
 
@@ -1235,7 +1229,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 }
 
 void
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
 {
     dVAR;
     IO *io;
@@ -1260,7 +1254,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 	PUSHMARK(SP);
 	EXTEND(SP,2);
 	PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-	mPUSHp(message, msglen);
+	PUSHs(msv);
 	PUTBACK;
 	call_method("PRINT", G_SCALAR);
 
@@ -1274,6 +1268,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 	dSAVED_ERRNO;
 #endif
 	PerlIO * const serr = Perl_error_log;
+	STRLEN msglen;
+	const char* message = SvPVx_const(msv, msglen);
 
 	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
 	(void)PerlIO_flush(serr);
@@ -1286,7 +1282,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 /* Common code used by vcroak, vdie, vwarn and vwarner  */
 
 STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_vdie_common(pTHX_ SV *message, bool warn)
 {
     dVAR;
     HV *stash;
@@ -1314,7 +1310,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 	    *hook = NULL;
 	}
 	if (warn || message) {
-	    msg = newSVpvn_flags(message, msglen, utf8);
+	    msg = newSVsv(message);
 	    SvREADONLY_on(msg);
 	    SAVEFREESV(msg);
 	}
@@ -1334,30 +1330,28 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
     return FALSE;
 }
 
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
-		    I32* utf8)
+STATIC SV *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args)
 {
     dVAR;
-    const char *message;
+    SV *message;
 
     if (pat) {
 	SV * const msv = vmess(pat, args);
 	if (PL_errors && SvCUR(PL_errors)) {
 	    sv_catsv(PL_errors, msv);
-	    message = SvPV_const(PL_errors, *msglen);
+	    message = sv_mortalcopy(PL_errors);
 	    SvCUR_set(PL_errors, 0);
 	}
 	else
-	    message = SvPV_const(msv,*msglen);
-	*utf8 = SvUTF8(msv);
+	    message = msv;
     }
     else {
 	message = NULL;
     }
 
     if (PL_diehook) {
-	S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
+	S_vdie_common(aTHX_ message, FALSE);
     }
     return message;
 }
@@ -1366,18 +1360,13 @@ static OP *
 S_vdie(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
-    const char *message;
-    const int was_in_eval = PL_in_eval;
-    STRLEN msglen;
-    I32 utf8 = 0;
+    SV *message;
 
-    message = vdie_croak_common(pat, args, &msglen, &utf8);
+    message = vdie_croak_common(pat, args);
 
-    PL_restartop = die_where(message, msglen);
-    SvFLAGS(ERRSV) |= utf8;
-    if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
-	JMPENV_JUMP(3);
-    return PL_restartop;
+    die_where(message);
+    /* NOTREACHED */
+    return NULL;
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1409,22 +1398,11 @@ void
 Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
-    const char *message;
-    STRLEN msglen;
-    I32 utf8 = 0;
+    SV *msv;
 
-    message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+    msv = S_vdie_croak_common(aTHX_ pat, args);
 
-    if (PL_in_eval) {
-	PL_restartop = die_where(message, msglen);
-	SvFLAGS(ERRSV) |= utf8;
-	JMPENV_JUMP(3);
-    }
-    else if (!message)
-	message = SvPVx_const(ERRSV, msglen);
-
-    write_to_stderr(message, msglen);
-    my_failure_exit();
+    die_where(msv);
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1474,19 +1452,16 @@ void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
-    STRLEN msglen;
     SV * const msv = vmess(pat, args);
-    const I32 utf8 = SvUTF8(msv);
-    const char * const message = SvPV_const(msv, msglen);
 
     PERL_ARGS_ASSERT_VWARN;
 
     if (PL_warnhook) {
-	if (vdie_common(message, msglen, utf8, TRUE))
+	if (vdie_common(msv, TRUE))
 	    return;
     }
 
-    write_to_stderr(message, msglen);
+    write_to_stderr(msv);
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1535,6 +1510,32 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER_D;
+
+    if (Perl_ckwarn_d(aTHX_ err)) {
+	va_list args;
+	va_start(args, pat);
+	vwarner(err, pat, &args);
+	va_end(args);
+    }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER;
+
+    if (Perl_ckwarn(aTHX_ err)) {
+	va_list args;
+	va_start(args, pat);
+	vwarner(err, pat, &args);
+	va_end(args);
+    }
+}
+
+void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
@@ -1551,21 +1552,12 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     PERL_ARGS_ASSERT_VWARNER;
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
 	SV * const msv = vmess(pat, args);
-	STRLEN msglen;
-	const char * const message = SvPV_const(msv, msglen);
-	const I32 utf8 = SvUTF8(msv);
 
 	if (PL_diehook) {
-	    assert(message);
-	    S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
-	}
-	if (PL_in_eval) {
-	    PL_restartop = die_where(message, msglen);
-	    SvFLAGS(ERRSV) |= utf8;
-	    JMPENV_JUMP(3);
+	    assert(msv);
+	    S_vdie_common(aTHX_ msv, FALSE);
 	}
-	write_to_stderr(message, msglen);
-	my_failure_exit();
+	die_where(msv);
     }
     else {
 	Perl_vwarn(aTHX_ pat, args);
@@ -1578,26 +1570,11 @@ bool
 Perl_ckwarn(pTHX_ U32 w)
 {
     dVAR;
-    return
-	(
-	       isLEXWARN_on
-	    && PL_curcop->cop_warnings != pWARN_NONE
-	    && (
-		   PL_curcop->cop_warnings == pWARN_ALL
-		|| isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-		|| (unpackWARN2(w) &&
-		     isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-		|| (unpackWARN3(w) &&
-		     isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-		|| (unpackWARN4(w) &&
-		     isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-		)
-	)
-	||
-	(
-	    isLEXWARN_off && PL_dowarn & G_WARN_ON
-	)
-	;
+    /* If lexical warnings have not been set, use $^W.  */
+    if (isLEXWARN_off)
+	return PL_dowarn & G_WARN_ON;
+
+    return ckwarn_common(w);
 }
 
 /* implements the ckWARN?_d macro */
@@ -1606,22 +1583,42 @@ bool
 Perl_ckwarn_d(pTHX_ U32 w)
 {
     dVAR;
-    return
-	   isLEXWARN_off
-	|| PL_curcop->cop_warnings == pWARN_ALL
-	|| (
-	      PL_curcop->cop_warnings != pWARN_NONE 
-	   && (
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-	      || (unpackWARN2(w) &&
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-	      || (unpackWARN3(w) &&
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-	      || (unpackWARN4(w) &&
-		   isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-	      )
-	   )
-	;
+    /* If lexical warnings have not been set then default classes warn.  */
+    if (isLEXWARN_off)
+	return TRUE;
+
+    return ckwarn_common(w);
+}
+
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+    if (PL_curcop->cop_warnings == pWARN_ALL)
+	return TRUE;
+
+    if (PL_curcop->cop_warnings == pWARN_NONE)
+	return FALSE;
+
+    /* Check the assumption that at least the first slot is non-zero.  */
+    assert(unpackWARN1(w));
+
+    /* Check the assumption that it is valid to stop as soon as a zero slot is
+       seen.  */
+    if (!unpackWARN2(w)) {
+	assert(!unpackWARN3(w));
+	assert(!unpackWARN4(w));
+    } else if (!unpackWARN3(w)) {
+	assert(!unpackWARN4(w));
+    }
+	
+    /* Right, dealt with all the special cases, which are implemented as non-
+       pointers, so there is a pointer to a real warnings mask.  */
+    do {
+	if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+	    return TRUE;
+    } while (w >>= WARNshift);
+
+    return FALSE;
 }
 
 /* Set buffer=NULL to get a new one.  */
@@ -2287,8 +2284,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    }
 	    return NULL;
 	}
-	if (ckWARN(WARN_PIPE))
-	    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+	Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
 	sleep(5);
     }
     if (pid == 0) {
@@ -2435,8 +2431,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 		Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
 	    return NULL;
 	}
-	if (ckWARN(WARN_PIPE))
-	    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+	Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
 	sleep(5);
     }
     if (pid == 0) {
@@ -3032,26 +3027,36 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 }
 #endif
 
+#define PERL_REPEATCPY_LINEAR 4
 void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
 {
-    register I32 todo;
-    register const char * const frombase = from;
-    PERL_UNUSED_CONTEXT;
-
     PERL_ARGS_ASSERT_REPEATCPY;
 
-    if (len == 1) {
-	register const char c = *from;
-	while (count-- > 0)
-	    *to++ = c;
-	return;
-    }
-    while (count-- > 0) {
-	for (todo = len; todo > 0; todo--) {
-	    *to++ = *from++;
+    if (len == 1)
+	memset(to, *from, count);
+    else if (count) {
+	register char *p = to;
+	I32 items, linear, half;
+
+	linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+	for (items = 0; items < linear; ++items) {
+	    register const char *q = from;
+	    I32 todo;
+	    for (todo = len; todo > 0; todo--)
+		*p++ = *q++;
+        }
+
+	half = count / 2;
+	while (items <= half) {
+	    I32 size = items * len;
+	    memcpy(p, to, size);
+	    p     += size;
+	    items *= 2;
 	}
-	from = frombase;
+
+	if (count > items)
+	    memcpy(p, to, (count - items) * len);
     }
 }
 
@@ -4297,9 +4302,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
  			mult /= 10;
 			if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
 			    || (PERL_ABS(rev) > VERSION_MAX )) {
-			    if(ckWARN(WARN_OVERFLOW))
-				Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-				"Integer overflow in version %d",VERSION_MAX);
+			    Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+					   "Integer overflow in version %d",VERSION_MAX);
 			    s = end - 1;
 			    rev = VERSION_MAX;
 			    vinf = 1;
@@ -4316,9 +4320,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
  			mult *= 10;
 			if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
 			    || (PERL_ABS(rev) > VERSION_MAX )) {
-			    if(ckWARN(WARN_OVERFLOW))
-				Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-				"Integer overflow in version");
+			    Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+					   "Integer overflow in version");
 			    end = s - 1;
 			    rev = VERSION_MAX;
 			    vinf = 1;
@@ -4566,10 +4569,9 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
-	if(ckWARN(WARN_MISC))
-	    Perl_warner(aTHX_ packWARN(WARN_MISC), 
-		"Version string '%s' contains invalid data; "
-		"ignoring: '%s'", version, s);
+	Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
+		       "Version string '%s' contains invalid data; "
+		       "ignoring: '%s'", version, s);
     Safefree(version);
     return ver;
 }
@@ -5364,7 +5366,7 @@ Perl_get_hash_seed(pTHX)
 	   * help.  Sum in another random number that will
 	   * fill in the low bits. */
 	  myseed +=
-	       (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+	       (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
 #endif /* RANDBITS < (UVSIZE * 8) */
 	  if (myseed == 0) { /* Superparanoia. */
 	      myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
@@ -6024,17 +6026,14 @@ Perl_my_dirfd(pTHX_ DIR * dir) {
 
 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
-    SV    *tmpsv;
 
     if (sv) {
         if (SvMAGICAL(sv))
             mg_get(sv);
-        if (SvROK(sv) &&
-            (tmpsv = MUTABLE_SV(SvRV(sv))) &&            /* assign deliberate */
-            SvTYPE(tmpsv) == SVt_REGEXP)
-        {
-            return (REGEXP*) tmpsv;
-        }
+        if (SvROK(sv))
+	    sv = MUTABLE_SV(SvRV(sv));
+        if (SvTYPE(sv) == SVt_REGEXP)
+            return (REGEXP*) sv;
     }
  
     return NULL;