From: Paul Marquess Date: Sun, 5 Sep 1999 15:11:08 +0000 (+0100) Subject: Another patch for Lexical Warnings X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=767a6a262e9f71124cfc78e5c518e24b20e6fd99;p=p5sagit%2Fp5-mst-13.2.git Another patch for Lexical Warnings Message-ID: <5104D4DBC598D211B5FE0000F8FE7EB202D49BAB@mbtlipnt02.btlabs.bt.co.uk> p4raw-id: //depot/perl@4088 --- diff --git a/pp_sys.c b/pp_sys.c index 6c80e5e..fd0ba8c 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1565,8 +1565,8 @@ PP(pp_sysread) length = -1; } if (length < 0) { - if (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout() - || IoIFP(io) == PerlIO_stderr()) + if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout() + || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO)) { SV* sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index e6de782..5101bde 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -1,60 +1,62 @@ - doio.c AOK + doio.c - Can't do bidirectional pipe + Can't do bidirectional pipe [Perl_do_open9] open(F, "| true |"); - Missing command in piped open + Missing command in piped open [Perl_do_open9] open(F, "| "); - Missing command in piped open + Missing command in piped open [Perl_do_open9] open(F, " |"); - warn(warn_nl, "open"); + warn(warn_nl, "open"); [Perl_do_open9] open(F, "true\ncd") - Close on unopened file <%s> - $a = "fred";close($a) + Close on unopened file <%s> [Perl_do_close] < + Stat on unopened file <%s> [Perl_my_stat] close STDIN ; -x STDIN ; - warn(warn_nl, "stat"); + warn(warn_nl, "stat"); [Perl_my_stat] stat "ab\ncd" - warn(warn_nl, "lstat"); + warn(warn_nl, "lstat"); [Perl_my_lstat] lstat "ab\ncd" - Can't exec \"%s\": %s + Can't exec \"%s\": %s [Perl_do_aexec5] - Can't exec \"%s\": %s + Can't exec \"%s\": %s [Perl_do_exec3] + Filehandle %s opened only for output [Perl_do_eof] + my $a = eof STDOUT Mandatory Warnings ALL TODO ------------------ - Can't do inplace edit: %s is not a regular file + Can't do inplace edit: %s is not a regular file [Perl_nextargv] edit a directory - Can't do inplace edit: %s would not be unique - Can't rename %s to %s: %s, skipping file - Can't rename %s to %s: %s, skipping file - Can't remove %s: %s, skipping file - Can't do inplace edit on %s: %s + Can't do inplace edit: %s would not be unique [Perl_nextargv] + Can't rename %s to %s: %s, skipping file [Perl_nextargv] + Can't rename %s to %s: %s, skipping file [Perl_nextargv] + Can't remove %s: %s, skipping file [Perl_nextargv] + Can't do inplace edit on %s: %s [Perl_nextargv] __END__ -# doio.c +# doio.c [Perl_do_open9] use warnings 'io' ; open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); close(F); @@ -64,7 +66,7 @@ close(G); EXPECT Can't do bidirectional pipe at - line 3. ######## -# doio.c +# doio.c [Perl_do_open9] use warnings 'io' ; open(F, "| "); no warnings 'io' ; @@ -72,7 +74,7 @@ open(G, "| "); EXPECT Missing command in piped open at - line 3. ######## -# doio.c +# doio.c [Perl_do_open9] use warnings 'io' ; open(F, " |"); no warnings 'io' ; @@ -80,7 +82,7 @@ open(G, " |"); EXPECT Missing command in piped open at - line 3. ######## -# doio.c +# doio.c [Perl_do_open9] use warnings 'io' ; open(F, " at - line 3. +######## +# doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat] use warnings 'io' ; close STDIN ; tell(STDIN); @@ -107,7 +117,7 @@ seek() on unopened file at - line 5. sysseek() on unopened file at - line 6. Stat on unopened file at - line 7. ######## -# doio.c +# doio.c [Perl_do_print] use warnings 'uninitialized' ; print $a ; no warnings 'uninitialized' ; @@ -115,13 +125,7 @@ print $b ; EXPECT Use of uninitialized value at - line 3. ######## -# doio.c -use warnings 'io' ; - -EXPECT - -######## -# doio.c +# doio.c [Perl_my_stat Perl_my_lstat] use warnings 'io' ; stat "ab\ncd"; lstat "ab\ncd"; @@ -132,7 +136,7 @@ EXPECT Unsuccessful stat on filename containing newline at - line 3. Unsuccessful stat on filename containing newline at - line 4. ######## -# doio.c +# doio.c [Perl_do_aexec5] use warnings 'io' ; exec "lskdjfalksdjfdjfkls","" ; no warnings 'io' ; @@ -141,7 +145,7 @@ EXPECT OPTION regex Can't exec "lskdjfalksdjfdjfkls": .+ ######## -# doio.c +# doio.c [Perl_do_exec3] use warnings 'io' ; exec "lskdjfalksdjfdjfkls", "abc" ; no warnings 'io' ; @@ -150,7 +154,7 @@ EXPECT OPTION regex Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ ######## -# doio.c +# doio.c [Perl_nextargv] $^W = 0 ; my $filename = "./temp" ; mkdir $filename, 0777 @@ -177,3 +181,11 @@ EXPECT Can't do inplace edit: ./temp is not a regular file at - line 9. Can't do inplace edit: ./temp is not a regular file at - line 21. +######## +# doio.c [Perl_do_eof] +use warnings 'io' ; +my $a = eof STDOUT ; +no warnings 'io' ; +$a = eof STDOUT ; +EXPECT +Filehandle main::STDOUT opened only for output at - line 3. diff --git a/t/pragma/warn/op b/t/pragma/warn/op index 07ec67c..e50420a 100644 --- a/t/pragma/warn/op +++ b/t/pragma/warn/op @@ -99,6 +99,10 @@ /---/ should probably be written as "---" join(/---/, @foo); + %s() called too early to check prototype [Perl_peep] + fred() ; sub fred ($$) {} + + Mandatory Warnings ------------------ Prototype mismatch: [cv_ckproto] @@ -794,3 +798,13 @@ use warnings 'syntax' ; join /---/, 'x', 'y', 'z'; EXPECT /---/ should probably be written as "---" at - line 3. +######## +# op.c [Perl_peep] +use warnings 'unsafe' ; +fred() ; +sub fred ($$) {} +no warnings 'unsafe' ; +joe() ; +sub joe ($$) {} +EXPECT +main::fred() called too early to check prototype at - line 3. diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index d0d339d..6bd3151 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -1,40 +1,49 @@ - pp_hot.c AOK + pp_hot.c - Filehandle %s never opened + Filehandle %s never opened [pp_print] $f = $a = "abc" ; print $f $a - Filehandle %s opened only for input + Filehandle %s opened only for input [pp_print] print STDIN "abc" ; - Filehandle %s opened only for output + Filehandle %s opened only for output [pp_print] print ; - print on closed filehandle %s + print on closed filehandle %s [pp_print] close STDIN ; print STDIN "abc" ; - uninitialized + uninitialized [pp_rv2av] my $a = undef ; my @b = @$a - uninitialized + uninitialized [pp_rv2hv] my $a = undef ; my %b = %$a - Odd number of elements in hash list + Odd number of elements in hash list [pp_aassign] %X = (1,2,3) ; - Reference found where even-sized list expected + Reference found where even-sized list expected [pp_aassign] $X = [ 1 ..3 ]; - Read on closed filehandle %s + Filehandle %s opened only for output [Perl_do_readline] + open (FH, ">./xcv") ; + my $a = ; + + glob failed (can't start child: %s) [Perl_do_readline] <; - Deep recursion on subroutine \"%s\" + glob failed (child exited with status %d%s) [Perl_do_readline] <; @@ -68,7 +77,7 @@ Filehandle main::FOO opened only for output at - line 6. Filehandle main::STDERR opened only for output at - line 7. Filehandle main::FOO opened only for output at - line 8. ######## -# pp_hot.c +# pp_hot.c [pp_print] use warnings 'closed' ; close STDIN ; print STDIN "anc"; @@ -77,7 +86,7 @@ print STDIN "anc"; EXPECT print on closed filehandle main::STDIN at - line 4. ######## -# pp_hot.c +# pp_hot.c [pp_rv2av] use warnings 'uninitialized' ; my $a = undef ; my @b = @$a; @@ -86,7 +95,7 @@ my @c = @$a; EXPECT Use of uninitialized value at - line 4. ######## -# pp_hot.c +# pp_hot.c [pp_rv2hv] use warnings 'uninitialized' ; my $a = undef ; my %b = %$a; @@ -95,7 +104,7 @@ my %c = %$a; EXPECT Use of uninitialized value at - line 4. ######## -# pp_hot.c +# pp_hot.c [pp_aassign] use warnings 'unsafe' ; my %X ; %X = (1,2,3) ; no warnings 'unsafe' ; @@ -103,7 +112,7 @@ my %Y ; %Y = (1,2,3) ; EXPECT Odd number of elements in hash assignment at - line 3. ######## -# pp_hot.c +# pp_hot.c [pp_aassign] use warnings 'unsafe' ; my %X ; %X = [1 .. 3] ; no warnings 'unsafe' ; @@ -111,7 +120,7 @@ my %Y ; %Y = [1 .. 3] ; EXPECT Reference found where even-sized list expected at - line 3. ######## -# pp_hot.c +# pp_hot.c [Perl_do_readline] use warnings 'closed' ; close STDIN ; $a = ; no warnings 'closed' ; @@ -119,7 +128,18 @@ $a = ; EXPECT Read on closed filehandle main::STDIN at - line 3. ######## -# pp_hot.c +# pp_hot.c [Perl_do_readline] +use warnings 'io' ; +my $file = "./xcv" ; unlink $file ; +open (FH, ">./xcv") ; +my $a = ; +no warnings 'io' ; +$a = ; +unlink $file ; +EXPECT +Filehandle main::FH opened only for output at - line 5. +######## +# pp_hot.c [Perl_sub_crush_depth] use warnings 'recursion' ; sub fred { @@ -134,7 +154,7 @@ sub fred EXPECT ok ######## -# pp_hot.c +# pp_hot.c [Perl_sub_crush_depth] no warnings 'recursion' ; sub fred { @@ -149,7 +169,7 @@ sub fred EXPECT ######## -# pp_hot.c +# pp_hot.c [Perl_sub_crush_depth] use warnings 'recursion' ; $b = sub { @@ -160,7 +180,7 @@ $b = sub EXPECT Deep recursion on anonymous subroutine at - line 5. ######## -# pp_hot.c +# pp_hot.c [Perl_sub_crush_depth] no warnings 'recursion' ; $b = sub { diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index d0caf96..651cdf9 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -1,83 +1,88 @@ pp_sys.c AOK - untie attempted while %d inner references still exist + untie attempted while %d inner references still exist [pp_untie] sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; - Filehandle %s opened only for input + Filehandle %s opened only for input [pp_leavewrite] format STDIN = . write STDIN; - Write on closed filehandle %s + Write on closed filehandle %s [pp_leavewrite] format STDIN = . close STDIN; write STDIN ; - page overflow + page overflow [pp_leavewrite] - Filehandle %s never opened + Filehandle %s never opened [pp_prtf] $a = "abc"; printf $a "fred" - Filehandle %s opened only for input + Filehandle %s opened only for input [pp_prtf] $a = "abc"; printf $a "fred" - printf on closed filehandle %s + printf on closed filehandle %s [pp_prtf] close STDIN ; printf STDIN "fred" - Syswrite on closed filehandle + Syswrite on closed filehandle [pp_send] close STDIN; syswrite STDIN, "fred", 1; - Send on closed socket + Send on closed socket [pp_send] close STDIN; send STDIN, "fred", 1 - bind() on closed fd + bind() on closed fd [pp_bind] close STDIN; bind STDIN, "fred" ; - connect() on closed fd + connect() on closed fd [pp_connect] close STDIN; connect STDIN, "fred" ; - listen() on closed fd + listen() on closed fd [pp_listen] close STDIN; listen STDIN, 2; - accept() on closed fd + accept() on closed fd [pp_accept] close STDIN; accept STDIN, "fred" ; - shutdown() on closed fd + shutdown() on closed fd [pp_shutdown] close STDIN; shutdown STDIN, 0; - [gs]etsockopt() on closed fd + [gs]etsockopt() on closed fd [pp_ssockopt] close STDIN; setsockopt STDIN, 1,2,3; getsockopt STDIN, 1,2; - get{sock, peer}name() on closed fd + get{sock, peer}name() on closed fd [pp_getpeername] close STDIN; getsockname STDIN; getpeername STDIN; - warn(warn_nl, "stat"); + warn(warn_nl, "stat"); [pp_stat] Test on unopened file <%s> close STDIN ; -T STDIN ; - warn(warn_nl, "open"); + warn(warn_nl, "open"); [pp_fttext] -T "abc\ndef" ; + Filehandle %s opened only for output [pp_sysread] + my $file = "./xcv" ; + open(F, ">$file") ; + my $a = sysread(F, $a,10) ; + __END__ -# pp_sys.c +# pp_sys.c [pp_untie] use warnings 'untie' ; sub TIESCALAR { bless [] } ; $b = tie $a, 'main'; @@ -88,7 +93,7 @@ untie $d ; EXPECT untie attempted while 1 inner references still exist at - line 5. ######## -# pp_sys.c +# pp_sys.c [pp_leavewrite] use warnings 'io' ; format STDIN = . @@ -98,7 +103,7 @@ write STDIN; EXPECT Filehandle main::STDIN opened only for input at - line 5. ######## -# pp_sys.c +# pp_sys.c [pp_leavewrite] use warnings 'closed' ; format STDIN = . @@ -109,7 +114,7 @@ write STDIN; EXPECT Write on closed filehandle main::STDIN at - line 6. ######## -# pp_sys.c +# pp_sys.c [pp_leavewrite] use warnings 'io' ; format STDOUT_TOP = abc @@ -127,7 +132,7 @@ write ; EXPECT page overflow at - line 13. ######## -# pp_sys.c +# pp_sys.c [pp_prtf] use warnings 'unopened' ; $a = "abc"; printf $a "fred"; @@ -136,7 +141,7 @@ printf $a "fred"; EXPECT Filehandle main::abc never opened at - line 4. ######## -# pp_sys.c +# pp_sys.c [pp_prtf] use warnings 'closed' ; close STDIN ; printf STDIN "fred"; @@ -145,7 +150,7 @@ printf STDIN "fred"; EXPECT printf on closed filehandle main::STDIN at - line 4. ######## -# pp_sys.c +# pp_sys.c [pp_prtf] use warnings 'io' ; printf STDIN "fred"; no warnings 'io' ; @@ -153,7 +158,7 @@ printf STDIN "fred"; EXPECT Filehandle main::STDIN opened only for input at - line 3. ######## -# pp_sys.c +# pp_sys.c [pp_send] use warnings 'closed' ; close STDIN; syswrite STDIN, "fred", 1; @@ -162,7 +167,7 @@ syswrite STDIN, "fred", 1; EXPECT Syswrite on closed filehandle at - line 4. ######## -# pp_sys.c +# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] use warnings 'io' ; use Config; BEGIN { @@ -216,7 +221,7 @@ shutdown() on closed fd at - line 27. get{sock, peer}name() on closed fd at - line 30. get{sock, peer}name() on closed fd at - line 31. ######## -# pp_sys.c +# pp_sys.c [pp_stat] use warnings 'newline' ; stat "abc\ndef"; no warnings 'newline' ; @@ -224,7 +229,7 @@ stat "abc\ndef"; EXPECT Unsuccessful stat on filename containing newline at - line 3. ######## -# pp_sys.c +# pp_sys.c [pp_fttext] use warnings 'unopened' ; close STDIN ; -T STDIN ; @@ -233,10 +238,22 @@ no warnings 'unopened' ; EXPECT Test on unopened file at - line 4. ######## -# pp_sys.c +# pp_sys.c [pp_fttext] use warnings 'newline' ; -T "abc\ndef" ; no warnings 'newline' ; -T "abc\ndef" ; EXPECT Unsuccessful open on filename containing newline at - line 3. +######## +# pp_sys.c [pp_sysread] +use warnings 'io' ; +my $file = "./xcv" ; +open(F, ">$file") ; +my $a = sysread(F, $a,10) ; +no warnings 'io' ; +my $a = sysread(F, $a,10) ; +close F ; +unlink $file ; +EXPECT +Filehandle main::F opened only for output at - line 5. diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index 6aa9fa6..9c3677e 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -1,18 +1,25 @@ regcomp.c AOK - %.*s matches null string many times + Strange *+?{} on zero-length expression [S_study_chunk] + /(?=a)?/ + %.*s matches null string many times [S_regpiece] $a = "ABC123" ; $a =~ /(?=a)*/' - Strange *+?{} on zero-length expression + /%.127s/: Unrecognized escape \\%c passed through" [S_regatom] + /\m/ - /(?=a)?/ + Character class syntax [. .] is reserved for future extensions [S_regpposixcc] + + Character class syntax [= =] is reserved for future extensions [S_checkposixcc] + + Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] + - Character class syntax [. .] is reserved for future extensions - Character class syntax [= =] is reserved for future extensions + __END__ -# regcomp.c +# regcomp.c [S_regpiece] use warnings 'unsafe' ; my $a = "ABC123" ; $a =~ /(?=a)*/ ; @@ -21,7 +28,7 @@ $a =~ /(?=a)*/ ; EXPECT (?=a)* matches null string many times at - line 4. ######## -# regcomp.c +# regcomp.c [S_study_chunk] use warnings 'unsafe' ; $_ = "" ; /(?=a)?/; @@ -30,7 +37,14 @@ no warnings 'unsafe' ; EXPECT Strange *+?{} on zero-length expression at - line 4. ######## -# regcomp.c +# regcomp.c [S_regatom] +use warnings 'unsafe' ; +$a =~ /\m/ ; +no warnings 'unsafe' ; +EXPECT +Unrecognized escape \m passed through at - line 3. +######## +# regcomp.c [S_regpposixcc S_checkposixcc] use warnings 'unsafe' ; $_ = "" ; /[:alpha:]/; diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index a90e9d3..bac2c42 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -32,6 +32,8 @@ Undefined value assigned to typeglob + Reference is already weak [Perl_sv_rvweaken] < %s non-portable + my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; + + Integer overflow in binary number + my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; Mandatory Warnings ------------------ @@ -524,3 +549,63 @@ Operator or semicolon missing before *foo at - line 8. Ambiguous use of * resolved as operator * at - line 8. Operator or semicolon missing before *foo at - line 10. Ambiguous use of * resolved as operator * at - line 10. +######## +# toke.c +use warnings 'unsafe' ; +my $a = "\m" ; +no warnings 'unsafe' ; +$a = "\m" ; +EXPECT +Unrecognized escape \m passed through at - line 3. +######## +# toke.c +use warnings 'portable' ; +my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +no warnings 'portable' ; + $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +EXPECT +Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. +Hexadecimal number > 0xffffffff non-portable at - line 8. +Octal number > 037777777777 non-portable at - line 11. +######## +# toke.c +use warnings 'overflow' ; +my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +no warnings 'overflow' ; + $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +EXPECT +Integer overflow in binary number at - line 5. +Integer overflow in hexadecimal number at - line 8. +Integer overflow in octal number at - line 11. diff --git a/t/pragma/warn/universal b/t/pragma/warn/universal index f4f8637..6dbb1be 100644 --- a/t/pragma/warn/universal +++ b/t/pragma/warn/universal @@ -1,11 +1,16 @@ - universal.c TODO + universal.c AOK - Can't locate package %s for @%s::ISA + Can't locate package %s for @%s::ISA [S_isa_lookup] + __END__ -# universal.c +# universal.c [S_isa_lookup] use warnings 'misc' ; - +@ISA = qw(Joe) ; +my $a = bless [] ; +UNIVERSAL::isa $a, Jim ; EXPECT - +Can't locate package Joe for @main::ISA at - line 5. +Can't locate package Joe for @main::ISA. +Can't locate package Joe for @main::ISA. diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8 index 30f552a..b11514d 100644 --- a/t/pragma/warn/utf8 +++ b/t/pragma/warn/utf8 @@ -15,13 +15,13 @@ <<<<<< Add a test when somethig actually calls utf16_to_utf8 __END__ -# utf8.c +# utf8.c [utf8_to_uv] use utf8 ; my $a = ord "\x80" ; EXPECT Malformed UTF-8 character at - line 3. ######## -# utf8.c +# utf8.c [utf8_to_uv] use utf8 ; my $a = ord "\x80" ; { @@ -35,13 +35,13 @@ Malformed UTF-8 character at - line 3. \x80 will produce malformed UTF-8 character; use \x{80} for that at - line 6. Malformed UTF-8 character at - line 6. ######## -# utf8.c +# utf8.c [utf8_to_uv] use utf8 ; my $a = ord "\xf080" ; EXPECT Malformed UTF-8 character at - line 3. ######## -# utf8.c +# utf8.c [utf8_to_uv] use utf8 ; my $a = ord "\xf080" ; { diff --git a/t/pragma/warn/util b/t/pragma/warn/util index e9093c4..6d82d13 100644 --- a/t/pragma/warn/util +++ b/t/pragma/warn/util @@ -8,28 +8,101 @@ Illegal binary digit ignored my $a = oct "0b9" ; + + Integer overflow in binary number + my $a = oct "0b111111111111111111111111111111111111111111" ; + Binary number > 0b11111111111111111111111111111111 non-portable + $a = oct "0b111111111111111111111111111111111" ; + Integer overflow in octal number + my $a = oct "0777777777777777777777777777777777777777777777777" ; + Octal number > 037777777777 non-portable + $a = oct "0047777777777" ; + Integer overflow in hexadecimal number + my $a = hex "0xffffffffffffffffffff" ; + Hexadecimal number > 0xffffffff non-portable + $a = hex "0x1ffffffff" ; __END__ # util.c use warnings 'digit' ; my $a = oct "029" ; no warnings 'digit' ; -my $a = oct "029" ; +$a = oct "029" ; EXPECT Illegal octal digit '9' ignored at - line 3. ######## # util.c use warnings 'digit' ; -*a = hex "0xv9" ; +my $a = hex "0xv9" ; no warnings 'digit' ; -*a = hex "0xv9" ; +$a = hex "0xv9" ; EXPECT Illegal hexadecimal digit 'v' ignored at - line 3. ######## # util.c use warnings 'digit' ; -*a = oct "0b9" ; +my $a = oct "0b9" ; no warnings 'digit' ; -*a = oct "0b9" ; +$a = oct "0b9" ; EXPECT Illegal binary digit '9' ignored at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = oct "0b111111111111111111111111111111111111111111" ; +no warnings 'overflow' ; +$a = oct "0b111111111111111111111111111111111111111111" ; +EXPECT +Integer overflow in binary number at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = hex "0xffffffffffffffffffff" ; +no warnings 'overflow' ; +$a = hex "0xffffffffffffffffffff" ; +EXPECT +Integer overflow in hexadecimal number at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = oct "0777777777777777777777777777777777777777777777777" ; +no warnings 'overflow' ; +$a = oct "0777777777777777777777777777777777777777777777777" ; +EXPECT +Integer overflow in octal number at - line 3. +######## +# util.c +use warnings 'portable' ; +my $a = oct "0b011111111111111111111111111111110" ; + $a = oct "0b011111111111111111111111111111111" ; + $a = oct "0b111111111111111111111111111111111" ; +no warnings 'portable' ; + $a = oct "0b011111111111111111111111111111110" ; + $a = oct "0b011111111111111111111111111111111" ; + $a = oct "0b111111111111111111111111111111111" ; +EXPECT +Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. +######## +# util.c +use warnings 'portable' ; +my $a = hex "0x0fffffffe" ; + $a = hex "0x0ffffffff" ; + $a = hex "0x1ffffffff" ; +no warnings 'portable' ; + $a = hex "0x0fffffffe" ; + $a = hex "0x0ffffffff" ; + $a = hex "0x1ffffffff" ; +EXPECT +Hexadecimal number > 0xffffffff non-portable at - line 5. +######## +# util.c +use warnings 'portable' ; +my $a = oct "0037777777776" ; + $a = oct "0037777777777" ; + $a = oct "0047777777777" ; +no warnings 'portable' ; + $a = oct "0037777777776" ; + $a = oct "0037777777777" ; + $a = oct "0047777777777" ; +EXPECT +Octal number > 037777777777 non-portable at - line 5. diff --git a/toke.c b/toke.c index 2561451..354b1d4 100644 --- a/toke.c +++ b/toke.c @@ -6582,9 +6582,8 @@ Perl_scan_num(pTHX_ char *start) dTHR; overflowed = TRUE; n = (NV) u; - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ ((shift == 3) ? - WARN_OCTAL : WARN_UNSAFE), + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in %s number", base); } else @@ -6613,8 +6612,8 @@ Perl_scan_num(pTHX_ char *start) sv = NEWSV(92,0); if (overflowed) { dTHR; - if (ckWARN(WARN_UNSAFE) && n > 4294967295.0) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) + Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", Base, max); sv_setnv(sv, n); @@ -6622,8 +6621,8 @@ Perl_scan_num(pTHX_ char *start) else { #if UV_SIZEOF > 4 dTHR; - if (ckWARN(WARN_UNSAFE) && u > 0xffffffff) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) + Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", Base, max); #endif