fixes for logical bugs in the lexwarn patch; other tweaks to avoid

type mismatch problems

p4raw-id: //depot/perl@3658

12 files changed, 70 insertions, 63 deletions

diff --git a/doio.c b/doio.c
index 1533bc5c97..a1adf63b1d 100644
--- a/doio.c
+++ b/doio.c
@@ -490,11 +490,12 @@ Perl_nextargv(pTHX_ register GV *gv)
 #ifdef DJGPP
                       || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
 #endif
-                      ) {
-		    if (ckWARN_d(WARN_INPLACE))	
-			Perl_warner(aTHX_ WARN_INPLACE,
-			  "Can't do inplace edit: %s would not be unique",
-			  SvPVX(sv) );
+                      )
+		    {
+			if (ckWARN_d(WARN_INPLACE))	
+			    Perl_warner(aTHX_ WARN_INPLACE,
+			      "Can't do inplace edit: %s would not be unique",
+			      SvPVX(sv));
 			do_close(gv,FALSE);
 			continue;
 		    }
diff --git a/gv.c b/gv.c
index 9fcf55b550..470ef11ccb 100644
--- a/gv.c
+++ b/gv.c
@@ -947,14 +947,16 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
+    dTHR;  
     GP* gp;
     CV* cv;
-    dTHR;  
 
     if (!gv || !(gp = GvGP(gv)))
 	return;
-    if (gp->gp_refcnt == 0 && ckWARN_d(WARN_INTERNAL)) {
-        Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced glob pointers");
+    if (gp->gp_refcnt == 0) {
+	if (ckWARN_d(WARN_INTERNAL))
+	    Perl_warner(aTHX_ WARN_INTERNAL,
+			"Attempt to free unreferenced glob pointers");
         return;
     }
     if (gp->gp_cv) {
diff --git a/op.c b/op.c
index f4dc624fce..eb4a0ed44b 100644
--- a/op.c
+++ b/op.c
@@ -3840,8 +3840,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
 {
     dTHR;
 
-    if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) &&
-		    ckWARN_d(WARN_UNSAFE) ) {
+    if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_UNSAFE)) {
 	SV* msg = sv_newmortal();
 	SV* name = Nullsv;
 
@@ -3928,8 +3927,10 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
 					   maximum a prototype before. */
 	if (SvTYPE(gv) > SVt_NULL) {
 	    if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
-			    && ckWARN_d(WARN_UNSAFE))
+		&& ckWARN_d(WARN_UNSAFE))
+	    {
 		Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype");
+	    }
 	    cv_ckproto((CV*)gv, NULL, ps);
 	}
 	if (ps)
@@ -4351,8 +4352,6 @@ OP *
 Perl_oopsHV(pTHX_ OP *o)
 {
     dTHR;
-
-    dTHR;
     
     switch (o->op_type) {
     case OP_PADSV:
diff --git a/pp.c b/pp.c
index 3f21cf2909..faa6656e38 100644
--- a/pp.c
+++ b/pp.c
@@ -3198,9 +3198,10 @@ PP(pp_reverse)
 			up = (char*)s;
 			s += UTF8SKIP(s);
 			down = (char*)(s - 1);
-			if ((s > send || !((*down & 0xc0) == 0x80)) &&
-					ckWARN_d(WARN_UTF8)) {
-			    Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
+			if (s > send || !((*down & 0xc0) == 0x80)) {
+			    if (ckWARN_d(WARN_UTF8))
+				Perl_warner(aTHX_ WARN_UTF8,
+					    "Malformed UTF-8 character");
 			    break;
 			}
 			while (down > up) {
diff --git a/regcomp.c b/regcomp.c
index 3569b3bbf1..8ce8426597 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -3031,7 +3031,7 @@ STATIC regnode *
 S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
 {
 #ifdef DEBUGGING
-    register char op = EXACT;	/* Arbitrary non-END op. */
+    register U8 op = EXACT;	/* Arbitrary non-END op. */
     register regnode *next, *onode;
 
     while (op != END && (!last || node < last)) {
diff --git a/regexec.c b/regexec.c
index 75f3873ce7..58d6af9c85 100644
--- a/regexec.c
+++ b/regexec.c
@@ -1254,7 +1254,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 	    break;
 	case ASCII:
 	    while (s < strend) {
-		if (isASCII(*s)) {
+		if (isASCII(*(U8*)s)) {
 		    if (tmp && regtry(prog, s))
 			goto got_it;
 		    else
@@ -1267,7 +1267,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 	    break;
 	case NASCII:
 	    while (s < strend) {
-		if (!isASCII(*s)) {
+		if (!isASCII(*(U8*)s)) {
 		    if (tmp && regtry(prog, s))
 			goto got_it;
 		    else
diff --git a/run.c b/run.c
index e218144b63..be532046c6 100644
--- a/run.c
+++ b/run.c
@@ -39,8 +39,9 @@ Perl_runops_debug(pTHX)
 {
 #ifdef DEBUGGING
     dTHR;
-    if (!PL_op && ckWARN_d(WARN_DEBUGGING)) {
-	Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
+    if (!PL_op) {
+	if (ckWARN_d(WARN_DEBUGGING))
+	    Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
 	return 0;
     }
 
diff --git a/sv.c b/sv.c
index 97044c9345..9973156bb9 100644
--- a/sv.c
+++ b/sv.c
@@ -3214,8 +3214,8 @@ Perl_sv_free(pTHX_ SV *sv)
 #ifdef DEBUGGING
     if (SvTEMP(sv)) {
 	if (ckWARN_d(WARN_DEBUGGING))
-	Perl_warner(aTHX_ WARN_DEBUGGING,
-	       "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
+	    Perl_warner(aTHX_ WARN_DEBUGGING,
+			"Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
 	return;
     }
 #endif
diff --git a/t/pragma/warn/op b/t/pragma/warn/op
index dce52d8c93..2377066622 100644
--- a/t/pragma/warn/op
+++ b/t/pragma/warn/op
@@ -555,6 +555,7 @@ Useless use of a constant in void context at - line 3.
 Useless use of a constant in void context at - line 4.
 ########
 # op.c
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # known scalar leak
 use warning 'unsafe' ;
 my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 @a =~ /abc/ ;
@@ -586,20 +587,20 @@ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 %$c =~ tr/a/b/ ;
 }
 EXPECT
-Applying pattern match to @array will act on scalar(@array) at - line 4.
-Applying substitution to @array will act on scalar(@array) at - line 5.
-Can't modify private array in substitution at - line 5, near "s/a/b/ ;"
-Applying character translation to @array will act on scalar(@array) at - line 6.
-Applying pattern match to @array will act on scalar(@array) at - line 7.
-Applying substitution to @array will act on scalar(@array) at - line 8.
-Applying character translation to @array will act on scalar(@array) at - line 9.
-Applying pattern match to %hash will act on scalar(%hash) at - line 10.
-Applying substitution to %hash will act on scalar(%hash) at - line 11.
-Applying character translation to %hash will act on scalar(%hash) at - line 12.
-Applying pattern match to %hash will act on scalar(%hash) at - line 13.
-Applying substitution to %hash will act on scalar(%hash) at - line 14.
-Applying character translation to %hash will act on scalar(%hash) at - line 15.
-BEGIN not safe after errors--compilation aborted at - line 17.
+Applying pattern match to @array will act on scalar(@array) at - line 5.
+Applying substitution to @array will act on scalar(@array) at - line 6.
+Can't modify private array in substitution at - line 6, near "s/a/b/ ;"
+Applying character translation to @array will act on scalar(@array) at - line 7.
+Applying pattern match to @array will act on scalar(@array) at - line 8.
+Applying substitution to @array will act on scalar(@array) at - line 9.
+Applying character translation to @array will act on scalar(@array) at - line 10.
+Applying pattern match to %hash will act on scalar(%hash) at - line 11.
+Applying substitution to %hash will act on scalar(%hash) at - line 12.
+Applying character translation to %hash will act on scalar(%hash) at - line 13.
+Applying pattern match to %hash will act on scalar(%hash) at - line 14.
+Applying substitution to %hash will act on scalar(%hash) at - line 15.
+Applying character translation to %hash will act on scalar(%hash) at - line 16.
+BEGIN not safe after errors--compilation aborted at - line 18.
 ########
 # op.c
 use warning 'syntax' ;
diff --git a/toke.c b/toke.c
index d9f54f78ba..d9e3bf7e7b 100644
--- a/toke.c
+++ b/toke.c
@@ -463,7 +463,6 @@ STATIC void
 S_check_uni(pTHX)
 {
     char *s;
-    char ch;
     char *t;
     dTHR;
 
@@ -475,7 +474,7 @@ S_check_uni(pTHX)
     if ((t = strchr(s, '(')) && t < PL_bufptr)
 	return;
     if (ckWARN_d(WARN_AMBIGUOUS)){
-        ch = *s;
+        char ch = *s;
         *s = '\0';
         Perl_warner(aTHX_ WARN_AMBIGUOUS, 
 		   "Warning: Use of \"%s\" without parens is ambiguous", 
@@ -3259,8 +3258,7 @@ Perl_yylex(pTHX)
 		}
 
 	    safe_bareword:
-		if (lastchar && strchr("*%&", lastchar) && 
-			ckWARN_d(WARN_AMBIGUOUS)) {
+		if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
 		    Perl_warner(aTHX_ WARN_AMBIGUOUS,
 		  	"Operator or semicolon missing before %c%s",
 			lastchar, PL_tokenbuf);
@@ -6000,10 +5998,10 @@ Perl_scan_num(pTHX_ char *start)
 	     we in octal/hex/binary?" indicator to disallow hex characters
 	     when in octal mode.
 	   */
+    	    dTHR;
 	    UV u;
 	    I32 shift;
 	    bool overflowed = FALSE;
-    	    dTHR;
 
 	    /* check for hex */
 	    if (s[1] == 'x') {
@@ -6071,10 +6069,13 @@ Perl_scan_num(pTHX_ char *start)
 		  digit:
 		    n = u << shift;	/* make room for the digit */
 		    if (!overflowed && (n >> shift) != u
-			&& !(PL_hints & HINT_NEW_BINARY) && ckWARN_d(WARN_UNSAFE)) {
-			Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in %s number",
-			     (shift == 4) ? "hex"
-			     : ((shift == 3) ? "octal" : "binary"));
+			&& !(PL_hints & HINT_NEW_BINARY))
+		    {
+			if (ckWARN_d(WARN_UNSAFE))
+			    Perl_warner(aTHX_ WARN_UNSAFE,
+					"Integer overflow in %s number",
+					(shift == 4) ? "hex"
+					    : ((shift == 3) ? "octal" : "binary"));
 			overflowed = TRUE;
 		    }
 		    u = n | b;		/* add the digit to the end */
diff --git a/utf8.c b/utf8.c
index 2090b7cbc5..bb0525d892 100644
--- a/utf8.c
+++ b/utf8.c
@@ -341,7 +341,7 @@ Perl_is_uni_print(pTHX_ U32 c)
 }
 
 bool
-is_uni_punct(U32 c)
+Perl_is_uni_punct(pTHX_ U32 c)
 {
     U8 tmpbuf[10];
     uv_to_utf8(tmpbuf, (UV)c);
diff --git a/util.c b/util.c
index 5f867aedfe..93742991c1 100644
--- a/util.c
+++ b/util.c
@@ -2752,14 +2752,15 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
     register UV retval = 0;
     bool overflowed = FALSE;
     while (len && *s >= '0' && *s <= '1') {
-      dTHR;	    
-      register UV n = retval << 1;
-      if (!overflowed && (n >> 1) != retval  && ckWARN_d(WARN_UNSAFE)) {
-          Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in binary number");
-          overflowed = TRUE;
-      }
-      retval = n | (*s++ - '0');
-      len--;
+	register UV n = retval << 1;
+	if (!overflowed && (n >> 1) != retval) {
+	    dTHR;
+	    if (ckWARN_d(WARN_UNSAFE))
+		Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in binary number");
+	    overflowed = TRUE;
+	}
+	retval = n | (*s++ - '0');
+	len--;
     }
     if (len && (*s >= '2' && *s <= '9')) {
       dTHR;
@@ -2777,10 +2778,11 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
     bool overflowed = FALSE;
 
     while (len && *s >= '0' && *s <= '7') {
-	dTHR;
 	register UV n = retval << 3;
-	if (!overflowed && (n >> 3) != retval && ckWARN_d(WARN_UNSAFE)) {
-	    Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in octal number");
+	if (!overflowed && (n >> 3) != retval) {
+	    dTHR;
+	    if (ckWARN_d(WARN_UNSAFE))
+		Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in octal number");
 	    overflowed = TRUE;
 	}
 	retval = n | (*s++ - '0');
@@ -2818,12 +2820,11 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
 	    }
 	}
 	n = retval << 4;
-	{
+	if (!overflowed && (n >> 4) != retval) {
 	    dTHR;
-	    if (!overflowed && (n >> 4) != retval && ckWARN_d(WARN_UNSAFE)) {
-	        Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in hex number");
-	        overflowed = TRUE;
-	    }
+	    if (ckWARN_d(WARN_UNSAFE))
+		Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in hex number");
+	    overflowed = TRUE;
 	}
 	retval = n | ((tmp - PL_hexdigit) & 15);
     }