From: Gurusamy Sarathy Date: Thu, 8 Jul 1999 01:24:25 +0000 (+0000) Subject: fixes for logical bugs in the lexwarn patch; other tweaks to avoid X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f248d07102861fd4d0819cc0b602f81105bc562c;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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); }