diff options
| -rw-r--r-- | doio.c | 11 | ||||
| -rw-r--r-- | gv.c | 8 | ||||
| -rw-r--r-- | op.c | 9 | ||||
| -rw-r--r-- | pp.c | 7 | ||||
| -rw-r--r-- | regcomp.c | 2 | ||||
| -rw-r--r-- | regexec.c | 4 | ||||
| -rw-r--r-- | run.c | 5 | ||||
| -rw-r--r-- | sv.c | 4 | ||||
| -rw-r--r-- | t/pragma/warn/op | 29 | ||||
| -rw-r--r-- | toke.c | 19 | ||||
| -rw-r--r-- | utf8.c | 2 | ||||
| -rw-r--r-- | util.c | 33 |
12 files changed, 70 insertions, 63 deletions
@@ -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; } @@ -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) { @@ -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: @@ -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) { @@ -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)) { @@ -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 @@ -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; } @@ -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' ; @@ -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 */ @@ -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); @@ -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); } |