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

type mismatch problems

p4raw-id: //depot/perl@3658

diff --git a/doio.c b/doio.c
index 1533bc5..a1adf63 100644 (file)
--- 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 9fcf55b..470ef11 100644 (file)
--- 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 f4dc624..eb4a0ed 100644 (file)
--- 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 3f21cf2..faa6656 100644 (file)
--- 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 3569b3b..8ce8426 100644 (file)
--- 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 75f3873..58d6af9 100644 (file)
--- 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 e218144..be53204 100644 (file)
--- 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 97044c9..9973156 100644 (file)
--- 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 dce52d8..2377066 100644 (file)
--- 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 d9f54f7..d9e3bf7 100644 (file)
--- 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 2090b7c..bb0525d 100644 (file)
--- 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 5f867ae..9374299 100644 (file)
--- 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);
     }