From: Gurusamy Sarathy <gsar@cpan.org>
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);
}