diff options
| author | Charles Bailey <bailey@newman.upenn.edu> | 2000-08-04 01:18:46 +0000 |
|---|---|---|
| committer | bailey <bailey@newman.upenn.edu> | 2000-08-04 01:18:46 +0000 |
| commit | 4b19af017623bfa3bb72bb164598a517f586e0d3 (patch) | |
| tree | ba3232ffa110ce6bfc48de096d48b00ae6788077 /t | |
| parent | 674d6c381cbfa67bc93fd195278b889049c14bba (diff) | |
| download | perl-4b19af017623bfa3bb72bb164598a517f586e0d3.tar.gz | |
YA resync with mainstem, including VMS patches from others
p4raw-id: //depot/vmsperl@6514
Diffstat (limited to 't')
63 files changed, 1666 insertions, 549 deletions
diff --git a/t/base/lex.t b/t/base/lex.t index d90d404cac..c7fb0e4cf3 100755 --- a/t/base/lex.t +++ b/t/base/lex.t @@ -1,6 +1,6 @@ #!./perl -print "1..46\n"; +print "1..51\n"; $x = 'x'; @@ -206,3 +206,42 @@ EOT print "# $@\nnot ok $test\n" if $@; T '^main:plink:53$', $test++; } + +# tests 47--51 start here +# tests for new array interpolation semantics: +# arrays now *always* interpolate into "..." strings. +# 20000522 MJD (mjd@plover.com) +{ + my $test = 47; + eval(q(">@nosuch<" eq "><")) || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # Look at this! This is going to be a common error in the future: + eval(q("fred@example.com" eq "fred.com")) || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # Let's make sure that normal array interpolation still works right + # For some reason, this appears not to be tested anywhere else. + my @a = (1,2,3); + print +((">@a<" eq ">1 2 3<") ? '' : 'not '), "ok $test\n"; + ++$test; + + # Ditto. + eval(q{@nosuch = ('a', 'b', 'c'); ">@nosuch<" eq ">a b c<"}) + || print "# $@", "not "; + print "ok $test\n"; + ++$test; + + # This isn't actually a lex test, but it's testing the same feature + sub makearray { + my @array = ('fish', 'dog', 'carrot'); + *R::crackers = \@array; + } + + eval(q{makearray(); ">@R::crackers<" eq ">fish dog carrot<"}) + || print "# $@", "not "; + print "ok $test\n"; + ++$test; +} diff --git a/t/comp/require.t b/t/comp/require.t index 1d92687355..bfd4a37fc9 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -7,7 +7,7 @@ BEGIN { # don't make this lexical $i = 1; -print "1..20\n"; +print "1..23\n"; sub do_require { %INC = (); @@ -19,6 +19,7 @@ sub do_require { sub write_file { my $f = shift; open(REQ,">$f") or die "Can't write '$f': $!"; + binmode REQ; print REQ @_; close REQ; } @@ -122,7 +123,19 @@ do "bleah.do"; dofile(); sub dofile { do "bleah.do"; }; print $x; -$i++; + +# UTF-encoded things +my $utf8 = chr(0xFEFF); + +$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n)); + +sub bytes_to_utf16 { + my $utf16 = pack("$_[0]*", unpack("C*", $_[1])); + return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; +} + +$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE +$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; } diff --git a/t/io/argv.t b/t/io/argv.t index d6093f90ef..2595fa681c 100755 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -5,7 +5,7 @@ BEGIN { unshift @INC, '../lib'; } -print "1..20\n"; +print "1..21\n"; use File::Spec; @@ -107,18 +107,20 @@ print "ok 15\n"; local $/; open F, 'Io_argv1.tmp' or die; <F>; # set $. = 1 + print "not " if defined(<F>); # should hit eof + print "ok 16\n"; open F, $devnull or die; print "not " unless defined(<F>); - print "ok 16\n"; - print "not " if defined(<F>); print "ok 17\n"; print "not " if defined(<F>); print "ok 18\n"; + print "not " if defined(<F>); + print "ok 19\n"; open F, $devnull or die; # restart cycle again print "not " unless defined(<F>); - print "ok 19\n"; - print "not " if defined(<F>); print "ok 20\n"; + print "not " if defined(<F>); + print "ok 21\n"; close F; } diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t index a7fca17811..e304766fc1 100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@ -5,6 +5,11 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; + require Config; import Config; + if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ + print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n"; + exit 0; + } } require AnyDBM_File; use Fcntl; @@ -31,7 +31,15 @@ print "not " if "{\n \$test /= 2 if ++\$test;\n}" ne $deparse->coderef2text(sub {++$test and $test/=2;}); ok; -my $a = `$^X -I../lib -MO=Deparse -anle 1 2>&1`; +my $a; +my $Is_VMS = $^O eq 'VMS'; +if ($Is_VMS) { + $^X = "MCR $^X"; + $a = `$^X "-I../lib" "-MO=Deparse" -anle "1"`; +} +else { + $a = `$^X -I../lib -MO=Deparse -anle 1 2>&1`; +} $a =~ s/-e syntax OK\n//g; $b = <<'EOF'; @@ -49,18 +57,33 @@ print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; ok; #6 -$a = `$^X -I../lib -MO=Debug -e 1 2>&1`; +if ($Is_VMS) { + $a = `$^X "-I../lib" "-MO=Debug" -e "1"`; +} +else { + $a = `$^X -I../lib -MO=Debug -e 1 2>&1`; +} print "not " unless $a =~ /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s; ok; #7 -$a = `$^X -I../lib -MO=Terse -e 1 2>&1`; +if ($Is_VMS) { + $a = `$^X "-I../lib" "-MO=Terse" -e "1"`; +} +else { + $a = `$^X -I../lib -MO=Terse -e 1 2>&1`; +} print "not " unless $a =~ /\bLISTOP\b.*leave.*\bOP\b.*enter.*\bCOP\b.*nextstate.*\bOP\b.*null/s; ok; -$a = `$^X -I../lib -MO=Terse -ane "s/foo/bar/" 2>&1`; +if ($Is_VMS) { + $a = `$^X "-I../lib" "-MO=Terse" -ane "s/foo/bar/"`; +} +else { + $a = `$^X -I../lib -MO=Terse -ane "s/foo/bar/" 2>&1`; +} $a =~ s/\(0x[^)]+\)//g; $a =~ s/\[[^\]]+\]//g; $a =~ s/-e syntax OK//; @@ -80,14 +103,29 @@ $b =~ s/\s+$//; print "# [$a] vs [$b]\nnot " if $a ne $b; ok; -chomp($a = `$^X -I../lib -MB::Stash -Mwarnings -e1`); +if ($Is_VMS) { + chomp($a = `$^X "-I../lib" "-MB::Stash" "-Mwarnings" -e "1"`); +} +else { + chomp($a = `$^X -I../lib -MB::Stash -Mwarnings -e1`); +} $a = join ',', sort split /,/, $a; -$a =~ s/-uWin32,//; -$b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-uwarnings'; -print "# [$a] vs [$b]\nnot " if $a ne $b; -ok; +$a =~ s/-uWin32,// if $^O eq 'MSWin32'; +$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; +if ($Config{static_ext} eq ' ') { + $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' + . '-umain,-uwarnings'; + print "# [$a] vs [$b]\nnot " if $a ne $b; + ok; +} else { + print "ok $test # skipped: one or more static extensions\n"; $test++; +} -$a = `$^X -I../lib -MO=Showlex -e "my %one" 2>&1`; +if ($Is_VMS) { + $a = `$^X "-I../lib" "-MO=Showlex" -e "my %one"`; +} +else { + $a = `$^X -I../lib -MO=Showlex -e "my %one" 2>&1`; +} print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; ok; diff --git a/t/lib/charnames.t b/t/lib/charnames.t index 566baf35b0..2e6a818677 100644 --- a/t/lib/charnames.t +++ b/t/lib/charnames.t @@ -8,7 +8,7 @@ BEGIN { } $| = 1; -print "1..12\n"; +print "1..13\n"; use charnames ':full'; @@ -78,3 +78,15 @@ sub to_bytes { print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; print "ok 12\n"; } + +{ + use charnames qw(:full); + use utf8; + + my $x = "\x{221b}"; + my $named = "\N{CUBE ROOT}"; + + print "not " unless ord($x) == ord($named); + print "ok 13\n"; +} + diff --git a/t/lib/complex.t b/t/lib/complex.t index d4beb8bded..b659142af9 100755 --- a/t/lib/complex.t +++ b/t/lib/complex.t @@ -27,7 +27,7 @@ my @script = ( my $eps = 1e-13; if ($^O eq 'unicos') { # For some reason root() produces very inaccurate - $eps = 1e-11; # results in Cray UNICOS, and occasionally also + $eps = 1e-10; # results in Cray UNICOS, and occasionally also } # cos(), sin(), cosh(), sinh(). The division # of doubles is the current suspect. @@ -262,7 +262,7 @@ EOS $test++; push @script, <<EOS; print "# j = \$j\n"; - print "not " unless "\$j" =~ /^-0\\.5\\+0.86602540\\d+i\$/; + print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/; print "ok $test\n"; \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); diff --git a/t/lib/dprof.t b/t/lib/dprof.t index 4d6f7823c3..fc5bd050cb 100755 --- a/t/lib/dprof.t +++ b/t/lib/dprof.t @@ -3,6 +3,11 @@ BEGIN { chdir( 't' ) if -d 't'; unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){ + print "1..0 # Skip: Devel::DProf was not built\n"; + exit 0; + } } END { @@ -11,7 +16,6 @@ END { use Benchmark qw( timediff timestr ); use Getopt::Std 'getopts'; -use Config '%Config'; getopts('vI:p:'); # -v Verbose diff --git a/t/lib/dumper-ovl.t b/t/lib/dumper-ovl.t index 8c095e59be..b8c8719318 100755 --- a/t/lib/dumper-ovl.t +++ b/t/lib/dumper-ovl.t @@ -3,6 +3,11 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; diff --git a/t/lib/dumper.t b/t/lib/dumper.t index b9680bd5e6..7b5a611b7d 100755 --- a/t/lib/dumper.t +++ b/t/lib/dumper.t @@ -6,6 +6,11 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; diff --git a/t/lib/english.t b/t/lib/english.t index dba68dbf94..6438d13176 100755 --- a/t/lib/english.t +++ b/t/lib/english.t @@ -1,9 +1,9 @@ #!./perl -print "1..16\n"; +print "1..22\n"; BEGIN { unshift @INC, '../lib' } -use English; +use English qw( -no_match_vars ) ; use Config; my $threads = $Config{'use5005threads'} || 0; @@ -17,13 +17,11 @@ sub foo { } &foo(1); -if ($threads) { - $_ = "ok 4\nok 5\nok 6\n"; -} else { - $ARG = "ok 4\nok 5\nok 6\n"; -} -/ok 5\n/; -print $PREMATCH, $MATCH, $POSTMATCH; +"abc" =~ /b/; + +print ! $PREMATCH ? "" : "not ", "ok 4\n" ; +print ! $MATCH ? "" : "not ", "ok 5\n" ; +print ! $POSTMATCH ? "" : "not ", "ok 6\n" ; $OFS = " "; $ORS = "\n"; @@ -43,5 +41,25 @@ print $GID == $( ? "ok 12\n" : "not ok 12\n"; print $EUID == $> ? "ok 13\n" : "not ok 13\n"; print $EGID == $) ? "ok 14\n" : "not ok 14\n"; -print $PROGRAM_NAME == $0 ? "ok 15\n" : "not ok 15\n"; +print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n"; print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n"; + +package B ; + +use English ; + +"abc" =~ /b/; + +print $PREMATCH ? "" : "not ", "ok 17\n" ; +print $MATCH ? "" : "not ", "ok 18\n" ; +print $POSTMATCH ? "" : "not ", "ok 19\n" ; + +package C ; + +use English qw( -no_match_vars ) ; + +"abc" =~ /b/; + +print ! $PREMATCH ? "" : "not ", "ok 20\n" ; +print ! $MATCH ? "" : "not ", "ok 21\n" ; +print ! $POSTMATCH ? "" : "not ", "ok 22\n" ; diff --git a/t/lib/filefind.t b/t/lib/filefind.t index e9a2916738..ca12e742ce 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -19,6 +19,7 @@ finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); my $case = 2; +my $FastFileTests_OK = 0; END { unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', @@ -57,8 +58,15 @@ sub wanted { print "# '$_' => 1\n"; s#\.$## if ($^O eq 'VMS' && $_ ne '.'); Check( $Expect{$_} ); - delete $Expect{$_}; + if ( $FastFileTests_OK ) { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d _ ); + } else { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d $_ ); + } $File::Find::prune=1 if $_ eq 'faba'; + } sub dn_wanted { @@ -106,6 +114,9 @@ touch('fa/fab/faba/faba_ord'); %Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); delete $Expect{'fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, + 'fb' => 1, 'fba' => 1); +delete @Expect_Dir{'fb','fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, },'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -113,6 +124,9 @@ Check( scalar(keys %Expect) == 0 ); 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); delete $Expect{'fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); +delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -122,6 +136,9 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&dn_wanted },'.' ); Check( scalar(keys %Expect) == 0 ); @@ -130,13 +147,19 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); Check( scalar(keys %Expect) == 0 ); if ( $symlink_exists ) { + $FastFileTests_OK= 1; %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -145,6 +168,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -152,6 +177,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -160,6 +187,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); diff --git a/t/lib/ftmp-mktemp.t b/t/lib/ftmp-mktemp.t index c660475709..35ab59cbb3 100755 --- a/t/lib/ftmp-mktemp.t +++ b/t/lib/ftmp-mktemp.t @@ -1,16 +1,16 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; -} +#!/usr/bin/perl -w # Test for mktemp family of commands in File::Temp # Use STANDARD safe level for these tests +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Test; import Test; + plan(tests => 9); +} + use strict; -use Test; -BEGIN { plan tests => 9 } use File::Spec; use File::Path; @@ -50,6 +50,7 @@ ok($string, $line); # stat(filehandle) does not always equal the size of the stat(filename) # This must be due to caching. In particular this test writes 7 bytes # to the file which are not recognised by stat(filename) +# Simply waiting 3 seconds seems to be enough for the system to update if ($^O eq 'MSWin32') { sleep 3; @@ -69,8 +70,15 @@ print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n"; # Check if the file exists ok( (-e $fname) ); -ok( unlink0($fh, $fname) ); +# This fails if you are running on NFS +# If this test fails simply skip it rather than doing a hard failure +my $status = unlink0($fh, $fname); +if ($status) { + ok($status); +} else { + skip("Skip test failed probably due to NFS",1) +} # MKDTEMP # Temp directory diff --git a/t/lib/ftmp-posix.t b/t/lib/ftmp-posix.t index f28785e87a..6802374b10 100755 --- a/t/lib/ftmp-posix.t +++ b/t/lib/ftmp-posix.t @@ -1,15 +1,14 @@ -#!./perl +#!/usr/bin/perl -w +# Test for File::Temp - POSIX functions BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Test; import Test; + plan(tests => 7); } -# Test for File::Temp - POSIX functions - use strict; -use Test; -BEGIN { plan tests => 7} use File::Temp qw/ :POSIX unlink0 /; ok(1); diff --git a/t/lib/ftmp-security.t b/t/lib/ftmp-security.t index 50e177958a..5f30f9651f 100755 --- a/t/lib/ftmp-security.t +++ b/t/lib/ftmp-security.t @@ -1,26 +1,31 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; -} - +#!/usr/bin/perl -w # Test for File::Temp - Security levels # Some of the security checking will not work on all platforms # Test a simple open in the cwd and tmpdir foreach of the # security levels -use strict; -use Test; -BEGIN { plan tests => 13} +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Test; import Test; + plan(tests => 13); +} +use strict; use File::Spec; + +# Set up END block - this needs to happen before we load +# File::Temp since this END block must be evaluated after the +# END block configured by File::Temp +my @files; # list of files to remove +END { foreach (@files) { ok( !(-e $_) )} } + use File::Temp qw/ tempfile unlink0 /; ok(1); # The high security tests must currently be skipped on Windows -my $skipplat = ( $^O eq 'MSWin32' ? 1 : 0 ); +my $skipplat = ( ($^O eq 'MSWin32' || $^O eq 'os2') ? 1 : 0 ); # Can not run high security tests in perls before 5.6.0 my $skipperl = ($] < 5.006 ? 1 : 0 ); @@ -77,27 +82,17 @@ sub test_security { # of tests -- we dont use skip since the tempfile() commands will # fail with MEDIUM/HIGH security before the skip() command would be run if ($skip) { - + skip($skip,1); skip($skip,1); - + # plus we need an end block so the tests come out in the right order eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; - + return; } - - # End blocks are evaluated in reverse order - # If I want to check that the file was unlinked by the autmoatic - # feature of the module I have to set up the end block before - # creating the file. - # Use quoted end block to retain access to lexicals - my @files; - - eval q{ END { foreach (@files) { ok( !(-e $_) )} } 1; } || die; - - + # Create the tempfile my $template = "temptestXXXXXXXX"; my ($fh1, $fname1) = tempfile ( $template, DIR => File::Spec->curdir, diff --git a/t/lib/ftmp-tempfile.t b/t/lib/ftmp-tempfile.t index 9c0de8b955..3cb73c20e0 100755 --- a/t/lib/ftmp-tempfile.t +++ b/t/lib/ftmp-tempfile.t @@ -1,30 +1,35 @@ -#!./perl +#!/usr/bin/perl -w +# Test for File::Temp - tempfile function BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Test; import Test; + plan(tests => 11); } -# Test for File::Temp - tempfile function - use strict; -use Test; -BEGIN { plan tests => 10} use File::Spec; -use File::Temp qw/ tempfile tempdir/; # Will need to check that all files were unlinked correctly -# Set up an END block here to do it (since the END blocks -# set up by File::Temp will be evaluated in reverse order we -# set ours up first.... +# Set up an END block here to do it + +my (@files, @dirs); # Array containing list of dirs/files to test # Loop over an array hoping that the files dont exist -my @files; -eval q{ END { foreach (@files) { ok( !(-e $_) )} } 1; } || die; +END { foreach (@files) { ok( !(-e $_) )} } # And a test for directories -my @dirs; -eval q{ END { foreach (@dirs) { ok( !(-d $_) )} } 1; } || die; +END { foreach (@dirs) { ok( !(-d $_) )} } + +# Need to make sure that the END blocks are setup before +# the ones that File::Temp configures since END blocks are evaluated +# in revers order and we need to check the files *after* File::Temp +# removes them +use File::Temp qw/ tempfile tempdir/; + +# Now we start the tests properly +ok(1); # Tempfile @@ -88,5 +93,5 @@ print "# TEMPFILE: Created $tempfile\n"; ok( (-f $tempfile) ); push(@files, $tempfile); -# no tests yet to make sure that the END{} blocks correctly remove -# the files +# Now END block will execute to test the removal of directories + diff --git a/t/lib/hostname.t b/t/lib/hostname.t index 6f61fb9dad..8a34e9c4e7 100755 --- a/t/lib/hostname.t +++ b/t/lib/hostname.t @@ -3,6 +3,11 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) { + print "1..0 # Skip: Sys::Hostname was not built\n"; + exit 0; + } } use Sys::Hostname; diff --git a/t/lib/ipc_sysv.t b/t/lib/ipc_sysv.t index a4f3e3f367..d2991e3eac 100755 --- a/t/lib/ipc_sysv.t +++ b/t/lib/ipc_sysv.t @@ -9,7 +9,9 @@ BEGIN { my $reason; - if ($Config{'d_sem'} ne 'define') { + if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) { + $reason = 'IPC::SysV was not built'; + } elsif ($Config{'d_sem'} ne 'define') { $reason = '$Config{d_sem} undefined'; } elsif ($Config{'d_msg'} ne 'define') { $reason = '$Config{d_msg} undefined'; diff --git a/t/lib/peek.t b/t/lib/peek.t index 255512fac5..86fd74a3df 100644 --- a/t/lib/peek.t +++ b/t/lib/peek.t @@ -285,8 +285,6 @@ do_test(17, MG_VIRTUAL = &PL_vtbl_glob MG_TYPE = \'\\*\' MG_OBJ = $ADDR - MG_LEN = 1 - MG_PTR = $ADDR "a" NAME = "a" NAMELEN = 1 GvSTASH = $ADDR\\t"main" diff --git a/t/lib/selfloader.t b/t/lib/selfloader.t new file mode 100755 index 0000000000..75d6561f9b --- /dev/null +++ b/t/lib/selfloader.t @@ -0,0 +1,200 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + $dir = "self-$$"; + unshift @INC, ("./$dir", "../lib"); + + print "1..19\n"; + + # First we must set up some selfloader files + mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; + + open(FOO, ">$dir/Foo.pm") or die; + print FOO <<'EOT'; +package Foo; +use SelfLoader; + +sub new { bless {}, shift } +sub foo; +sub bar; +sub bazmarkhianish; +sub a; +sub never; # declared but definition should never be read +1; +__DATA__ + +sub foo { shift; shift || "foo" }; + +sub bar { shift; shift || "bar" } + +sub bazmarkhianish { shift; shift || "baz" } + +package sheep; +sub bleat { shift; shift || "baa" } + +__END__ +sub never { die "D'oh" } +EOT + + close(FOO); + + open(BAR, ">$dir/Bar.pm") or die; + print BAR <<'EOT'; +package Bar; +use SelfLoader; + +@ISA = 'Baz'; + +sub new { bless {}, shift } +sub a; + +1; +__DATA__ + +sub a { 'a Bar'; } +sub b { 'b Bar' } + +__END__ DATA +sub never { die "D'oh" } +EOT + + close(BAR); +}; + + +package Baz; + +sub a { 'a Baz' } +sub b { 'b Baz' } +sub c { 'c Baz' } + + +package main; +use Foo; +use Bar; + +$foo = new Foo; + +print "not " unless $foo->foo eq 'foo'; # selfloaded first time +print "ok 1\n"; + +print "not " unless $foo->foo eq 'foo'; # regular call +print "ok 2\n"; + +# Try an undefined method +eval { + $foo->will_fail; +}; +if ($@ =~ /^Undefined subroutine/) { + print "ok 3\n"; +} else { + print "not ok 3 $@\n"; +} + +# Used to be trouble with this +eval { + my $foo = new Foo; + die "oops"; +}; +if ($@ =~ /oops/) { + print "ok 4\n"; +} else { + print "not ok 4 $@\n"; +} + +# Pass regular expression variable to autoloaded function. This used +# to go wrong in AutoLoader because it used regular expressions to generate +# autoloaded filename. +"foo" =~ /(\w+)/; +print "not " unless $1 eq 'foo'; +print "ok 5\n"; + +print "not " unless $foo->bar($1) eq 'foo'; +print "ok 6\n"; + +print "not " unless $foo->bar($1) eq 'foo'; +print "ok 7\n"; + +print "not " unless $foo->bazmarkhianish($1) eq 'foo'; +print "ok 8\n"; + +print "not " unless $foo->bazmarkhianish($1) eq 'foo'; +print "ok 9\n"; + +# Check nested packages inside __DATA__ +print "not " unless sheep::bleat() eq 'baa'; +print "ok 10\n"; + +# Now check inheritance: + +$bar = new Bar; + +# Before anything is SelfLoaded there is no declaration of Foo::b so we should +# get Baz::b +print "not " unless $bar->b() eq 'b Baz'; +print "ok 11\n"; + +# There is no Bar::c so we should get Baz::c +print "not " unless $bar->c() eq 'c Baz'; +print "ok 12\n"; + +# This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side +# effect +print "not " unless $bar->a() eq 'a Bar'; +print "ok 13\n"; + +print "not " unless $bar->b() eq 'b Bar'; +print "ok 14\n"; + +print "not " unless $bar->c() eq 'c Baz'; +print "ok 15\n"; + + + +# Check that __END__ is honoured +# Try an subroutine that should never be noticed by selfloader +eval { + $foo->never; +}; +if ($@ =~ /^Undefined subroutine/) { + print "ok 16\n"; +} else { + print "not ok 16 $@\n"; +} + +# Try to read from the data file handle +my $foodata = <Foo::DATA>; +close Foo::DATA; +if (defined $foodata) { + print "not ok 17 # $foodata\n"; +} else { + print "ok 17\n"; +} + +# Check that __END__ DATA is honoured +# Try an subroutine that should never be noticed by selfloader +eval { + $bar->never; +}; +if ($@ =~ /^Undefined subroutine/) { + print "ok 18\n"; +} else { + print "not ok 18 $@\n"; +} + +# Try to read from the data file handle +my $bardata = <Bar::DATA>; +close Bar::DATA; +if ($bardata ne "sub never { die \"D'oh\" }\n") { + print "not ok 19 # $bardata\n"; +} else { + print "ok 19\n"; +} + +# cleanup +END { +return unless $dir && -d $dir; +unlink "$dir/Foo.pm", "$dir/Bar.pm"; +rmdir "$dir"; +} diff --git a/t/lib/syslfs.t b/t/lib/syslfs.t index 2857120942..3cfe3022da 100644 --- a/t/lib/syslfs.t +++ b/t/lib/syslfs.t @@ -8,7 +8,7 @@ BEGIN { require Config; import Config; # Don't bother if there are no quad offsets. if ($Config{lseeksize} < 8) { - print "1..0\n# no 64-bit file offsets\n"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); @@ -47,14 +47,14 @@ print "# checking whether we have sparse files...\n"; # Known have-nots. if ($^O eq 'win32' || $^O eq 'vms') { - print "1..0\n# no sparse files (because this is $^O) \n"; + print "1..0 # Skip: no sparse files (because this is $^O) \n"; bye(); } # Known haves that have problems running this test # (for example because they do not support sparse files, like UNICOS) if ($^O eq 'unicos') { - print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + print "1..0 # Skip: large files known to work but unable to test them here ($^O)\n"; bye(); } @@ -95,7 +95,7 @@ zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0\n#no sparse files?\n"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -103,15 +103,25 @@ print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-I../lib', '-e', <<'EOF'; +use Fcntl qw(/^O_/ /^SEEK_/); +sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!; +my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); +my $syswrite = syswrite(BIG, "big"); +exit 0; +EOF + sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or do { warn "sysopen 'big' failed: $!\n"; bye }; my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -unless (defined $sysseek && $sysseek == 5_000_000_000) { - print "1..0\n# seeking past 2GB failed: $! (sysseek returned ", - defined $sysseek ? $sysseek : 'undef', ")\n"; +unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { + $sysseek = 'undef' unless defined $sysseek; + print "1..0 # Skip: seeking past 2GB failed: ", + $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)", "\n"; explain(); bye(); } @@ -125,9 +135,9 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless($syswrite && $close) { if ($! =~/too large/i) { - print "1..0\n# writing past 2GB failed: process limits?\n"; + print "1..0 # Skip: writing past 2GB failed: process limits?\n"; } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + print "1..0 # Skip: filesystem quota limits?\n"; } explain(); bye(); @@ -138,7 +148,7 @@ unless($syswrite && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; + print "1..0 # Skip: not configured to use large files?\n"; explain(); bye(); } diff --git a/t/op/64bitint.t b/t/op/64bitint.t index f59c953825..691d44e240 100644 --- a/t/op/64bitint.t +++ b/t/op/64bitint.t @@ -123,85 +123,106 @@ $x = $q - $r; print "not " unless $x == -11111110111 && -$x > $f; print "ok 22\n"; -$x = $q * 1234567; -print "not " unless $x == 15241567763770867 && $x > $f; -print "ok 23\n"; - -$x /= 1234567; -print "not " unless $x == $q && $x > $f; -print "ok 24\n"; - -$x = 98765432109 % 12345678901; -print "not " unless $x == 901; -print "ok 25\n"; - -# The following 12 tests adapted from op/inc. - -$a = 9223372036854775807; -$c = $a++; -print "not " unless $a == 9223372036854775808; -print "ok 26\n"; - -$a = 9223372036854775807; -$c = ++$a; -print "not " unless $a == 9223372036854775808 && $c == $a; -print "ok 27\n"; - -$a = 9223372036854775807; -$c = $a + 1; -print "not " unless $a == 9223372036854775807 && $c == 9223372036854775808; -print "ok 28\n"; - -$a = -9223372036854775808; -$c = $a--; -print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; -print "ok 29\n"; - -$a = -9223372036854775808; -$c = --$a; -print "not " unless $a == -9223372036854775809 && $c == $a; -print "ok 30\n"; - -$a = -9223372036854775808; -$c = $a - 1; -print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; -print "ok 31\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = $a--; -print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; -print "ok 32\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = --$a; -print "not " unless $a == -9223372036854775809 && $c == $a; -print "ok 33\n"; - -$a = 9223372036854775808; -$a = -$a; -$c = $a - 1; -print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; -print "ok 34\n"; - -$a = 9223372036854775808; -$b = -$a; -$c = $b--; -print "not " unless $b == -$a-1 && $c == -$a; -print "ok 35\n"; - -$a = 9223372036854775808; -$b = -$a; -$c = --$b; -print "not " unless $b == -$a-1 && $c == $b; -print "ok 36\n"; - -$a = 9223372036854775808; -$b = -$a; -$b = $b - 1; -print "not " unless $b == -(++$a); -print "ok 37\n"; +if ($^O ne 'unicos') { + $x = $q * 1234567; + print "not " unless $x == 15241567763770867 && $x > $f; + print "ok 23\n"; + + $x /= 1234567; + print "not " unless $x == $q && $x > $f; + print "ok 24\n"; + + $x = 98765432109 % 12345678901; + print "not " unless $x == 901; + print "ok 25\n"; + + # The following 12 tests adapted from op/inc. + + $a = 9223372036854775807; + $c = $a++; + print "not " unless $a == 9223372036854775808; + print "ok 26\n"; + + $a = 9223372036854775807; + $c = ++$a; + print "not " + unless $a == 9223372036854775808 && $c == $a; + print "ok 27\n"; + + $a = 9223372036854775807; + $c = $a + 1; + print "not " + unless $a == 9223372036854775807 && $c == 9223372036854775808; + print "ok 28\n"; + + $a = -9223372036854775808; + $c = $a--; + print "not " + unless $a == -9223372036854775809 && $c == -9223372036854775808; + print "ok 29\n"; + + $a = -9223372036854775808; + $c = --$a; + print "not " + unless $a == -9223372036854775809 && $c == $a; + print "ok 30\n"; + + $a = -9223372036854775808; + $c = $a - 1; + print "not " + unless $a == -9223372036854775808 && $c == -9223372036854775809; + print "ok 31\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = $a--; + print "not " + unless $a == -9223372036854775809 && $c == -9223372036854775808; + print "ok 32\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = --$a; + print "not " + unless $a == -9223372036854775809 && $c == $a; + print "ok 33\n"; + + $a = 9223372036854775808; + $a = -$a; + $c = $a - 1; + print "not " + unless $a == -9223372036854775808 && $c == -9223372036854775809; + print "ok 34\n"; + + $a = 9223372036854775808; + $b = -$a; + $c = $b--; + print "not " + unless $b == -$a-1 && $c == -$a; + print "ok 35\n"; + + $a = 9223372036854775808; + $b = -$a; + $c = --$b; + print "not " + unless $b == -$a-1 && $c == $b; + print "ok 36\n"; + + $a = 9223372036854775808; + $b = -$a; + $b = $b - 1; + print "not " + unless $b == -(++$a); + print "ok 37\n"; + +} else { + # Unicos has imprecise doubles (14 decimal digits or so), + # especially if operating near the UV/IV limits the low-order bits + # become mangled even by simple arithmetic operations. + for (23..37) { + print "ok #_ # skipped: too imprecise numbers\n"; + } +} $x = ''; @@ -233,17 +254,23 @@ print "ok 45\n"; print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; print "ok 46\n"; -print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; +print "not " + unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; print "ok 47\n"; -print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; +print "not " + unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; print "ok 48\n"; -print "not " unless (sprintf "%b", ~0) eq '1111111111111111111111111111111111111111111111111111111111111111'; +print "not " + unless (sprintf "%b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; print "ok 49\n"; -print "not " unless (sprintf "%64b", ~0) eq '1111111111111111111111111111111111111111111111111111111111111111'; +print "not " + unless (sprintf "%64b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; print "ok 50\n"; print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807'; diff --git a/t/op/args.t b/t/op/args.t index 48bf5afec0..ce2c398865 100755 --- a/t/op/args.t +++ b/t/op/args.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; # test various operations on @_ @@ -52,3 +52,24 @@ sub new4 { goto &new2 } print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; print "ok $ord\n"; } + +# see if POPSUB gets to see the right pad across a dounwind() with +# a reified @_ + +sub methimpl { + my $refarg = \@_; + die( "got: @_\n" ); +} + +sub method { + &methimpl; +} + +sub try { + eval { method('foo', 'bar'); }; + print "# $@" if $@; +} + +for (1..5) { try() } +++$ord; +print "ok $ord\n"; diff --git a/t/op/arith.t b/t/op/arith.t index fe2f0f458b..5b04f9365f 100755 --- a/t/op/arith.t +++ b/t/op/arith.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..12\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -21,3 +21,10 @@ try 5, abs( 13e21 % 4e21 - 1e21) < $limit; try 6, abs(-13e21 % 4e21 - 3e21) < $limit; try 7, abs( 13e21 % -4e21 - -3e21) < $limit; try 8, abs(-13e21 % -4e21 - -1e21) < $limit; + +# UVs should behave properly + +try 9, 4063328477 % 65535 == 27407; +try 10, 4063328477 % 4063328476 == 1; +try 11, 4063328477 % 2031664238 == 1; +try 12, 2031664238 % 4063328477 == 2031664238; @@ -21,18 +21,18 @@ print "1..15\n"; $_[0] = "not ok 1\n"; $result = do foo1("ok 1\n"); print "#2\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; } -if ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; } +if ($result eq 'value') { print "ok 2\n"; } else { print "not ok 2\n"; } +if ($_[0] eq "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; } $_[0] = "not ok 4\n"; $result = do foo2("not ok 4\n","ok 4\n","not ok 4\n"); print "#5\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; } -if ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; } +if ($result eq 'value') { print "ok 5\n"; } else { print "not ok 5\n"; } +if ($_[0] eq "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; } $result = do{print "ok 7\n"; 'value';}; print "#8\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; } +if ($result eq 'value') { print "ok 8\n"; } else { print "not ok 8\n"; } sub blather { print @_; @@ -11,7 +11,7 @@ BEGIN { use warnings; -print "1..30\n"; +print "1..41\n"; # type coersion on assignment $foo = 'foo'; @@ -97,15 +97,19 @@ $x = "ok 17\n"; %x = ("ok 19" => "\n"); sub x { "ok 20\n" } print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; +format x = +ok 21 +. +print ref *x{FORMAT} eq "FORMAT" ? "ok 21\n" : "not ok 21\n"; *x = *STDOUT; -print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n"; -print {*x{IO}} "ok 22\n"; -print {*x{FILEHANDLE}} "ok 23\n"; +print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 22\n" : "not ok 22\n"; +print {*x{IO}} "ok 23\n"; +print {*x{FILEHANDLE}} "ok 24\n"; # test if defined() doesn't create any new symbols { - my $test = 23; + my $test = 24; my $a = "SYM000"; print "not " if defined *{$a}; @@ -128,6 +132,42 @@ print {*x{FILEHANDLE}} "ok 23\n"; ++$test; &{$a}; } +# although it *should* if you're talking about magicals + +{ + my $test = 30; + + my $a = "]"; + print "not " unless defined ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + + $a = "1"; + "o" =~ /(o)/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "2"; + print "not " if ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "1x"; + print "not " if defined ${$a}; + ++$test; print "ok $test\n"; + print "not " if defined *{$a}; + ++$test; print "ok $test\n"; + $a = "11"; + "o" =~ /(((((((((((o)))))))))))/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; +} + + # does pp_readline() handle glob-ness correctly? { @@ -137,4 +177,4 @@ print {*x{FILEHANDLE}} "ok 23\n"; } __END__ -ok 30 +ok 41 diff --git a/t/op/lfs.t b/t/op/lfs.t index e704f6f57b..97c920c2cf 100644 --- a/t/op/lfs.t +++ b/t/op/lfs.t @@ -8,7 +8,7 @@ BEGIN { # Don't bother if there are no quad offsets. require Config; import Config; if ($Config{lseeksize} < 8) { - print "1..0\n# no 64-bit file offsets\n"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } } @@ -46,14 +46,14 @@ print "# checking whether we have sparse files...\n"; # Known have-nots. if ($^O eq 'win32' || $^O eq 'vms') { - print "1..0\n# no sparse files (because this is $^O) \n"; + print "1..0 # Skip: no sparse files (because this is $^O) \n"; bye(); } # Known haves that have problems running this test # (for example because they do not support sparse files, like UNICOS) if ($^O eq 'unicos') { - print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + print "1..0 # Skip: large files known to work but unable to test them here ($^O)\n"; bye(); } @@ -102,7 +102,7 @@ zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0\n#no sparse files?\n"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -110,13 +110,22 @@ print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-e', <<'EOF'; +open(BIG, ">big"); +seek(BIG, 5_000_000_000, 0); +print BIG "big"; +exit 0; +EOF + open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; binmode BIG; -unless (seek(BIG, 5_000_000_000, $SEEK_SET)) { - print "1..0\n# seeking past 2GB failed: $!\n"; +if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { + my $err = $r ? 'signal '.($r & 0x7f) : $!; + print "1..0 # Skip: seeking past 2GB failed: $err\n"; explain(); bye(); } @@ -129,9 +138,9 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless ($print && $close) { if ($! =~/too large/i) { - print "1..0\n# writing past 2GB failed: process limits?\n"; + print "1..0 # Skip: writing past 2GB failed: process limits?\n"; } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + print "1..0 # Skip: filesystem quota limits?\n"; } explain(); bye(); @@ -142,7 +151,7 @@ unless ($print && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; + print "1..0 # Skip: not configured to use large files?\n"; explain(); bye(); } diff --git a/t/op/method.t b/t/op/method.t index 1c6f3c5d9d..6e25310734 100755 --- a/t/op/method.t +++ b/t/op/method.t @@ -4,7 +4,12 @@ # test method calls and autoloading. # -print "1..49\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; +} + +print "1..53\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -167,3 +172,16 @@ test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); test(A2->foo(), "foo"); } + +{ + test(do { use Config; eval 'Config->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); + test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); +} + +test(do { eval 'E->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); +test(do { eval '$e = bless {}, "E"; $e->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); + diff --git a/t/op/misc.t b/t/op/misc.t index 55f459d49b..00abc99b45 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -558,3 +558,7 @@ eval "C"; M(C); EXPECT Modification of a read-only value attempted at - line 2. +######## +print qw(ab a\b a\\b); +EXPECT +aba\ba\b diff --git a/t/op/my_stash.t b/t/op/my_stash.t new file mode 100644 index 0000000000..79f3f28a08 --- /dev/null +++ b/t/op/my_stash.t @@ -0,0 +1,31 @@ +#!./perl + +package Foo; + +BEGIN { + unshift @INC, "../lib"; +} + +use Test; + +plan tests => 7; + +use constant MyClass => 'Foo::Bar::Biz::Baz'; + +{ + package Foo::Bar::Biz::Baz; +} + +for (qw(Foo Foo:: MyClass __PACKAGE__)) { + eval "sub { my $_ \$obj = shift; }"; + ok ! $@; +# print $@ if $@; +} + +use constant NoClass => 'Nope::Foo::Bar::Biz::Baz'; + +for (qw(Nope Nope:: NoClass)) { + eval "sub { my $_ \$obj = shift; }"; + ok $@; +# print $@ if $@; +} diff --git a/t/op/numconvert.t b/t/op/numconvert.t index 8eb9b6e341..f3c9867a91 100755 --- a/t/op/numconvert.t +++ b/t/op/numconvert.t @@ -51,7 +51,13 @@ my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { - print "1..0\n# Unsigned arithmetic is not sane\n"; + print "1..0 # skipped: unsigned perl arithmetic is not sane"; + eval { require Config; import Config }; + use vars qw(%Config); + if ($Config{d_quad} eq 'define') { + print " (common in 64-bit platforms)"; + } + print "\n"; exit 0; } diff --git a/t/op/pack.t b/t/op/pack.t index dda1cc76d7..5c215c6f0f 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..156\n"; +print "1..159\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -406,3 +406,13 @@ $z = pack <<EOP,'string','etc'; w/A* # Count a BER integer EOP print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; + +print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless "1.20.300.4000" eq + sprintf "%vd", pack(" U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless v1.20.300.4000 ne + sprintf "%vd", pack("C0U*",1,20,300,4000); +print "ok $test\n"; $test++; + diff --git a/t/op/pat.t b/t/op/pat.t index e00328c91f..81591fc71b 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -4,7 +4,7 @@ # the format supported by op/regexp.t. If you want to add a test # that does fit that format, add it to op/re_tests, not here. -print "1..213\n"; +print "1..215\n"; BEGIN { chdir 't' if -d 't'; @@ -1012,3 +1012,12 @@ EOE $a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; print "ok $test\n"; $test++; + +# test result of match used as match (!) +'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; + +'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; diff --git a/t/op/re_tests b/t/op/re_tests index 189077c628..38483253d3 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -750,4 +750,28 @@ tt+$ xxxtt y - - ^([a-z]:) C:/ n - - '^\S\s+aa$'m \nx aa y - - (^|a)b ab y - - +^([ab]*?)(b)?(c)$ abac y -$2- -- +(\w)?(abc)\1b abcab n - - +^(?:.,){2}c a,b,c y - - +^(.,){2}c a,b,c y $1 b, +^(?:[^,]*,){2}c a,b,c y - - +^([^,]*,){2}c a,b,c y $1 b, +^([^,]*,){3}d aaa,b,c,d y $1 c, +^([^,]*,){3,}d aaa,b,c,d y $1 c, +^([^,]*,){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,},){0,3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c, (?i) y - - +'(?!\A)x'm a\nxb\n y - - +^(a(b)?)+$ aba y -$1-$2- -a-- +^(aa(bb)?)+$ aabbaa y -$1-$2- -aa-- +'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - - +^(a)?a$ a y -$1- -- +^(a)?(?(1)a|b)+$ a n - - diff --git a/t/op/runlevel.t b/t/op/runlevel.t index e988ad9362..3865e52070 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -349,3 +349,18 @@ A 1 bar B 2 bar +######## +sub n { 0 } +sub f { my $x = shift; d(); } +f(n()); +f(); + +sub d { + my $i = 0; my @a; + while (do { { package DB; @a = caller($i++) } } ) { + @a = @DB::args; + for (@a) { print "$_\n"; $_ = '' } + } +} +EXPECT +0 diff --git a/t/op/split.t b/t/op/split.t index 8b9f4ad2f9..78f51f5954 100755 --- a/t/op/split.t +++ b/t/op/split.t @@ -2,7 +2,7 @@ # $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $ -print "1..25\n"; +print "1..27\n"; $FS = ':'; @@ -109,3 +109,12 @@ print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n"; $_ = "a : b :c: d"; @ary = split(/\s*:\s*/); if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";} + +# use of match result as pattern (!) +'p:q:r:s' eq join ':', split('abc' =~ /b/, 'p1q1r1s') or print "not "; +print "ok 26\n"; + +# /^/ treated as /^/m +$_ = join ':', split /^/, "ab\ncd\nef\n"; +print "not " if $_ ne "ab\n:cd\n:ef\n"; +print "ok 27\n"; diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 4d54d2c317..c48435592d 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -1,6 +1,10 @@ #!./perl -# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ +# Tests sprintf, excluding handling of 64-bit integers or long +# doubles (if supported), of machine-specific short and long +# integers, machine-specific floating point exceptions (infinity, +# not-a-number ...), of the effects of locale, and of features +# specific to multi-byte characters (under use utf8 and such). BEGIN { chdir 't' if -d 't'; @@ -8,31 +12,273 @@ BEGIN { } use warnings; -print "1..4\n"; +while (<DATA>) { + s/^\s*>//; s/<\s*$//; + push @tests, [split(/<\s*>/, $_, 4)]; +} + +print '1..', scalar @tests, "\n"; $SIG{__WARN__} = sub { if ($_[0] =~ /^Invalid conversion/) { - $w++; + $w = ' INVALID' } else { warn @_; } }; -$w = 0; -$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b %x %X %#b %#x %#X","hi",123,0,456,0,ord('A'),3.0999,11,171,171,11,171,171); -if ($x eq ' hi 123 %foo 456 0A3.1 1011 ab AB 0b1011 0xab 0XAB' && $w == 0) { - print "ok 1\n"; -} else { - print "not ok 1 '$x'\n"; -} +for ($i = 1; @tests; $i++) { + ($template, $data, $result, $comment) = @{shift @tests}; + $evalData = eval $data; + $w = undef; + $x = sprintf(">$template<", + defined @$evalData ? @$evalData : $evalData); + substr($x, -1, 0) = $w if $w; + # $x may have 3 exponent digits, not 2 + my $y = $x; + if ($y =~ s/([Ee][-+])0(\d)/$1$2/) { + # if result is left-adjusted, append extra space + if ($template =~ /%\+?\-/ and $result =~ / $/) { + $y =~ s/<$/ </; + } + # if result is zero-filled, add extra zero + elsif ($template =~ /%\+?0/ and $result =~ /^0/) { + $y =~ s/^>0/>00/; + } + # if result is right-adjusted, prepend extra space + elsif ($result =~ /^ /) { + $y =~ s/^>/> /; + } + } -for $i (2 .. 4) { - $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2]; - $w = 0; - $x = sprintf($f, ''); - if ($x eq $f && $w == 1) { - print "ok $i\n"; - } else { - print "not ok $i '$x' '$f' '$w'\n"; + if ($x eq ">$result<") { + print "ok $i\n"; + } + elsif ($y eq ">$result<") # Some C libraries always give + { # three-digit exponent + print("ok $i >$result< $x # three-digit exponent accepted\n"); + } + else { + $y = ($x eq $y ? "" : " => $y"); + print("not ok $i >$template< >$data< >$result< $x$y", + $comment ? " # $comment\n" : "\n"); } } + +# In each of the the following lines, there are three required fields: +# printf template, data to be formatted (as a Perl expression), and +# expected result of formatting. An optional fourth field can contain +# a comment. Each field is delimited by a starting '>' and a +# finishing '<'; any whitespace outside these start and end marks is +# not part of the field. If formatting requires more than one data +# item (for example, if variable field widths are used), the Perl data +# expression should return a reference to an array having the requisite +# number of elements. Even so, subterfuge is sometimes required: see +# tests for %n and %p. +# +# template data result +__END__ +>%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< +>%6 .6s< >''< >%6 .6s INVALID< +>%6.6 s< >''< >%6.6 s INVALID< +>%A< >''< >%A INVALID< +>%B< >''< >%B INVALID< +>%C< >''< >%C INVALID< +>%D< >0x7fffffff< >2147483647< >Synonym for %ld< +>%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< +>%F< >123456.789< >123456.789000< >Synonym for %f< +>%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"< +>%G< >1234567e96< >1.23457E+102< +>%G< >.1234567e-101< >1.23457E-102< +>%G< >12345.6789< >12345.7< +>%H< >''< >%H INVALID< +>%I< >''< >%I INVALID< +>%J< >''< >%J INVALID< +>%K< >''< >%K INVALID< +>%L< >''< >%L INVALID< +>%M< >''< >%M INVALID< +>%N< >''< >%N INVALID< +>%O< >2**32-1< >37777777777< >Synonum for %lo< +>%P< >''< >%P INVALID< +>%Q< >''< >%Q INVALID< +>%R< >''< >%R INVALID< +>%S< >''< >%S INVALID< +>%T< >''< >%T INVALID< +>%U< >2**32-1< >4294967295< >Synonum for %lu< +>%V< >''< >%V INVALID< +>%W< >''< >%W INVALID< +>%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< +>%#X< >2**32-1< >0XFFFFFFFF< +>%Y< >''< >%Y INVALID< +>%Z< >''< >%Z INVALID< +>%a< >''< >%a INVALID< +>%b< >2**32-1< >11111111111111111111111111111111< +>%+b< >2**32-1< >11111111111111111111111111111111< +>%#b< >2**32-1< >0b11111111111111111111111111111111< +>%34b< >2**32-1< > 11111111111111111111111111111111< +>%034b< >2**32-1< >0011111111111111111111111111111111< +>%-34b< >2**32-1< >11111111111111111111111111111111 < +>%-034b< >2**32-1< >11111111111111111111111111111111 < +>%c< >ord('A')< >A< +>%10c< >ord('A')< > A< +>%#10c< >ord('A')< > A< ># modifier: no effect< +>%010c< >ord('A')< >000000000A< +>%10lc< >ord('A')< > A< >l modifier: no effect< +>%10hc< >ord('A')< > A< >h modifier: no effect< +>%10.5c< >ord('A')< > A< >precision: no effect< +>%-10c< >ord('A')< >A < +>%d< >123456.789< >123456< +>%d< >-123456.789< >-123456< +>%d< >0< >0< +>%+d< >0< >+0< +>%0d< >0< >0< +>%.0d< >0< >< +>%+.0d< >0< >+< +>%.0d< >1< >1< +>%d< >1< >1< +>%+d< >1< >+1< +>%#3.2d< >1< > 01< ># modifier: no effect< +>%3.2d< >1< > 01< +>%03.2d< >1< >001< +>%-3.2d< >1< >01 < +>%-03.2d< >1< >01 < >zero pad + left just.: no effect< +>%d< >-1< >-1< +>%+d< >-1< >-1< +>%hd< >1< >1< >More extensive testing of< +>%ld< >1< >1< >length modifiers would be< +>%Vd< >1< >1< >platform-specific< +>%vd< >chr(1)< >1< +>%+vd< >chr(1)< >+1< +>%#vd< >chr(1)< >1< +>%vd< >"\01\02\03"< >1.2.3< +>%v.3d< >"\01\02\03"< >001.002.003< +>%v03d< >"\01\02\03"< >001.002.003< +>%v-3d< >"\01\02\03"< >1 .2 .3 < +>%v+-3d< >"\01\02\03"< >+1 .2 .3 < +>%v4.3d< >"\01\02\03"< > 001. 002. 003< +>%v04.3d< >"\01\02\03"< >0001.0002.0003< +>%*v02d< >['-', "\0\7\14"]< >00-07-12< +>%v.*d< >[3, "\01\02\03"]< >001.002.003< +>%v0*d< >[3, "\01\02\03"]< >001.002.003< +>%v-*d< >[3, "\01\02\03"]< >1 .2 .3 < +>%v+-*d< >[3, "\01\02\03"]< >+1 .2 .3 < +>%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< +>%v0*.*d< >[4, 3, "\01\02\03"]< >0001.0002.0003< +>%*v0*d< >['-', 2, "\0\7\13"]< >00-07-11< +>%e< >1234.875< >1.234875e+03< +>%e< >0.000012345< >1.234500e-05< +>%e< >1234567E96< >1.234567e+102< +>%e< >0< >0.000000e+00< +>%e< >.1234567E-101< >1.234567e-102< +>%+e< >1234.875< >+1.234875e+03< +>%#e< >1234.875< >1.234875e+03< +>%e< >-1234.875< >-1.234875e+03< +>%+e< >-1234.875< >-1.234875e+03< +>%#e< >-1234.875< >-1.234875e+03< +>%.0e< >1234.875< >1e+03< +>%.*e< >[0, 1234.875]< >1e+03< +>%.1e< >1234.875< >1.2e+03< +>%-12.4e< >1234.875< >1.2349e+03 < +>%12.4e< >1234.875< > 1.2349e+03< +>%+-12.4e< >1234.875< >+1.2349e+03 < +>%+12.4e< >1234.875< > +1.2349e+03< +>%+-12.4e< >-1234.875< >-1.2349e+03 < +>%+12.4e< >-1234.875< > -1.2349e+03< +>%f< >1234.875< >1234.875000< +>%+f< >1234.875< >+1234.875000< +>%#f< >1234.875< >1234.875000< +>%f< >-1234.875< >-1234.875000< +>%+f< >-1234.875< >-1234.875000< +>%#f< >-1234.875< >-1234.875000< +>%6f< >1234.875< >1234.875000< +>%*f< >[6, 1234.875]< >1234.875000< +>%.0f< >1234.875< >1235< +>%.1f< >1234.875< >1234.9< +>%-8.1f< >1234.875< >1234.9 < +>%8.1f< >1234.875< > 1234.9< +>%+-8.1f< >1234.875< >+1234.9 < +>%+8.1f< >1234.875< > +1234.9< +>%+-8.1f< >-1234.875< >-1234.9 < +>%+8.1f< >-1234.875< > -1234.9< +>%*.*f< >[5, 2, 12.3456]< >12.35< +>%f< >0< >0.000000< +>%.0f< >0< >0< +>%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< +>%.0f< >0.1< >0< +>%.0f< >-0.1< >-0< +>%.0f< >0.6< >1< +>%.0f< >-0.6< >-1< +>%g< >12345.6789< >12345.7< +>%+g< >12345.6789< >+12345.7< +>%#g< >12345.6789< >12345.7< +>%.0g< >12345.6789< >1e+04< +>%.2g< >12345.6789< >1.2e+04< +>%.*g< >[2, 12345.6789]< >1.2e+04< +>%.9g< >12345.6789< >12345.6789< +>%12.9g< >12345.6789< > 12345.6789< +>%012.9g< >12345.6789< >0012345.6789< +>%-12.9g< >12345.6789< >12345.6789 < +>%*.*g< >[-12, 9, 12345.6789]< >12345.6789 < +>%-012.9g< >12345.6789< >12345.6789 < +>%g< >-12345.6789< >-12345.7< +>%+g< >-12345.6789< >-12345.7< +>%g< >1234567.89< >1.23457e+06< +>%+g< >1234567.89< >+1.23457e+06< +>%#g< >1234567.89< >1.23457e+06< +>%g< >-1234567.89< >-1.23457e+06< +>%+g< >-1234567.89< >-1.23457e+06< +>%#g< >-1234567.89< >-1.23457e+06< +>%g< >0.00012345< >0.00012345< +>%g< >0.000012345< >1.2345e-05< +>%g< >1234567E96< >1.23457e+102< +>%g< >.1234567E-101< >1.23457e-102< +>%g< >0< >0< +>%13g< >1234567.89< > 1.23457e+06< +>%+13g< >1234567.89< > +1.23457e+06< +>%013g< >1234567.89< >001.23457e+06< +>%-13g< >1234567.89< >1.23457e+06 < +>%h< >''< >%h INVALID< +>%i< >123456.789< >123456< >Synonym for %d< +>%j< >''< >%j INVALID< +>%k< >''< >%k INVALID< +>%l< >''< >%l INVALID< +>%m< >''< >%m INVALID< +>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< +>%o< >2**32-1< >37777777777< +>%+o< >2**32-1< >37777777777< +>%#o< >2**32-1< >037777777777< +>%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< +>%#p< >''< >%#p INVALID< +>%q< >''< >%q INVALID< +>%r< >''< >%r INVALID< +>%s< >'string'< >string< +>%10s< >'string'< > string< +>%+10s< >'string'< > string< +>%#10s< >'string'< > string< +>%010s< >'string'< >0000string< +>%0*s< >[10, 'string']< >0000string< +>%-10s< >'string'< >string < +>%3s< >'string'< >string< +>%.3s< >'string'< >str< +>%.*s< >[3, 'string']< >str< +>%t< >''< >%t INVALID< +>%u< >2**32-1< >4294967295< +>%+u< >2**32-1< >4294967295< +>%#u< >2**32-1< >4294967295< +>%12u< >2**32-1< > 4294967295< +>%012u< >2**32-1< >004294967295< +>%-12u< >2**32-1< >4294967295 < +>%-012u< >2**32-1< >4294967295 < +>%v< >''< >%v INVALID< +>%w< >''< >%w INVALID< +>%x< >2**32-1< >ffffffff< +>%+x< >2**32-1< >ffffffff< +>%#x< >2**32-1< >0xffffffff< +>%10x< >2**32-1< > ffffffff< +>%010x< >2**32-1< >00ffffffff< +>%-10x< >2**32-1< >ffffffff < +>%-010x< >2**32-1< >ffffffff < +>%0-10x< >2**32-1< >ffffffff < +>%0*x< >[-10, ,2**32-1]< >ffffffff < +>%y< >''< >%y INVALID< +>%z< >''< >%z INVALID< diff --git a/t/op/stat.t b/t/op/stat.t index af4920cd43..353b3b3b2f 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -80,6 +80,7 @@ else { print "not ok 4\n"; print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; + print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n"; } print "#4 :$mtime: should != :$ctime:\n"; diff --git a/t/op/taint.t b/t/op/taint.t index 6548b46f59..44f50aea18 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -24,7 +24,8 @@ BEGIN { $ENV{PATH} = $ENV{PATH}; $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; } - if ($Config{d_shm} || $Config{d_msg}) { + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ + && ($Config{d_shm} || $Config{d_msg})) { require IPC::SysV; IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); } @@ -612,13 +613,13 @@ else { # test shmread { - if ($Config{d_shm}) { + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) { no strict 'subs'; my $sent = "foobar"; my $rcvd; my $size = 2000; - my $id = shmget(IPC_PRIVATE, $size, S_IRWXU) || - warn "# shmget failed: $!\n"; + my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); + if (defined $id) { if (shmwrite($id, $sent, 0, 60)) { if (shmread($id, $rcvd, 0, 60)) { @@ -629,7 +630,7 @@ else { } else { warn "# shmwrite failed: $!\n"; } - shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n"; + shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; } else { warn "# shmget failed: $!\n"; } @@ -646,7 +647,7 @@ else { # test msgrcv { - if ($Config{d_msg}) { + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) { no strict 'subs'; my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); @@ -665,7 +666,7 @@ else { } else { warn "# msgsnd failed\n"; } - msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n"; + msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; } else { warn "# msgget failed\n"; } @@ -5,7 +5,7 @@ BEGIN { unshift @INC, "../lib"; } -print "1..4\n"; +print "1..27\n"; $_ = "abcdefghijklmnopqrstuvwxyz"; @@ -37,3 +37,129 @@ print "ok 3\n"; print "ok 4\n"; } # + +# make sure that tr cancels IOK and NOK +($x = 12) =~ tr/1/3/; +(my $y = 12) =~ tr/1/3/; +($f = 1.5) =~ tr/1/3/; +(my $g = 1.5) =~ tr/1/3/; +print "not " unless $x + $y + $f + $g == 71; +print "ok 5\n"; + +# make sure tr is harmless if not updating - see [ID 20000511.005] +$_ = 'fred'; +/([a-z]{2})/; +$1 =~ tr/A-Z//; +s/^(\s*)f/$1F/; +print "not " if $_ ne 'Fred'; +print "ok 6\n"; + +# check tr handles UTF8 correctly +($x = 256.65.258) =~ tr/a/b/; +print "not " if $x ne 256.65.258 or length $x != 3; +print "ok 7\n"; +$x =~ tr/A/B/; +print "not " if $x ne 256.66.258 or length $x != 3; +print "ok 8\n"; + +{ +use utf8; + +# 9 - changing UTF8 characters in a UTF8 string, same length. +$l = chr(300); $r = chr(400); +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{190}/; +printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3; +print "ok 9\n"; + +# 10 - changing UTF8 characters in UTF8 string, more bytes. +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{be8}/; +printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3; +print "ok 10\n"; + +# 11 - introducing UTF8 characters to non-UTF8 string. +$x = 100.125.60; +$x =~ tr/\x{64}/\x{190}/; +printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3; +print "ok 11\n"; + +# 12 - removing UTF8 characters from UTF8 string +$x = 400.125.60; +$x =~ tr/\x{190}/\x{64}/; +printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3; +print "ok 12\n"; + +# 13 - counting UTF8 chars in UTF8 string +$x = 400.125.60.400; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 2; +print "ok 13\n"; + +# 14 - counting non-UTF8 chars in UTF8 string +$x = 60.400.125.60.400; +$y = $x =~ tr/\x{3c}/\x{3c}/; +print "not " if $y != 2; +print "ok 14\n"; + +# 15 - counting UTF8 chars in non-UTF8 string +$x = 200.125.60; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 0; +print "ok 15\n"; +} + +# 16: test brokenness with tr/a-z-9//; +$_ = "abcdefghijklmnopqrstuvwxyz"; +eval "tr/a-z-9/ /"; +print (($@ =~ /^Ambiguous range in transliteration operator/) + ? '' : 'not ', "ok 16\n"); + +# 17-19: Make sure leading and trailing hyphens still work +$_ = "car-rot9"; +tr/-a-m/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 17\n"); + +$_ = "car-rot9"; +tr/a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 18\n"); + +$_ = "car-rot9"; +tr/-a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n"); + +$_ = "abcdefghijklmnop"; +tr/ae-hn/./; +print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 20\n"); + +$_ = "abcdefghijklmnop"; +tr/a-cf-kn-p/./; +print (($_ eq '...de......lm...') ? '' : 'not ', "ok 21\n"); + +$_ = "abcdefghijklmnop"; +tr/a-ceg-ikm-o/./; +print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 22\n"); + +# 23: Test reversed range check +# 20000705 MJD +eval "tr/m-d/ /"; +print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/) + ? '' : 'not ', "ok 23\n"); + +# 24: test cannot update if read-only +eval '$1 =~ tr/x/y/'; +print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ', + "ok 24\n"); + +# 25: test can count read-only +'abcdef' =~ /(bcd)/; +print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 25\n"); + +# 26: test lhs OK if not updating +print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 26\n"); + +# 27: test lhs bad if updating +eval '"123" =~ tr/1/1/'; +print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|) + ? '' : 'not ', "ok 27\n"); + diff --git a/t/op/vec.t b/t/op/vec.t index bf60fc4a08..b8efb8011d 100755 --- a/t/op/vec.t +++ b/t/op/vec.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $ - -print "1..15\n"; +print "1..18\n"; print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; @@ -25,3 +23,11 @@ vec($Vec, 0, 32) = 0xbaddacab; print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n"; print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n"; +# ensure vec() handles numericalness correctly +$foo = $bar = $baz = 0; +vec($foo = 0,0,1) = 1; +vec($bar = 0,1,1) = 1; +$baz = $foo | $bar; +print $foo eq "1" && $foo == 1 ? "ok 16\n" : "not ok 16\n"; +print $bar eq "2" && $bar == 2 ? "ok 17\n" : "not ok 17\n"; +print "$foo $bar $baz" eq "1 2 3" ? "ok 18\n" : "not ok 18\n"; diff --git a/t/op/wantarray.t b/t/op/wantarray.t index 0a47b6d3ba..4b6f37cf0f 100755 --- a/t/op/wantarray.t +++ b/t/op/wantarray.t @@ -1,6 +1,6 @@ #!./perl -print "1..3\n"; +print "1..7\n"; sub context { my ( $cona, $testnum ) = @_; my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; @@ -13,4 +13,8 @@ sub context { context('V',1); $a = context('S',2); @a = context('A',3); +scalar context('S',4); +$a = scalar context('S',5); +($a) = context('A',6); +($a) = scalar context('S',7); 1; diff --git a/t/op/write.t b/t/op/write.t index 87d50429f4..5b01eb78b7 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -200,4 +200,21 @@ $this,$that write LEX; $that = 8; write LEX; + close LEX; } +# LEX_INTERPNORMAL test +my %e = ( a => 1 ); +format OUT4 = +@<<<<<< +"$e{a}" +. +open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; +write (OUT4); +close OUT4; +if (`$CAT Op_write.tmp` eq "1\n") { + print "ok 9\n"; + unlink "Op_write.tmp"; + } +else { + print "not ok 9\n"; + } diff --git a/t/pragma/constant.t b/t/pragma/constant.t index 6438332cff..dde64ceebd 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -212,8 +212,9 @@ eval q{ use constant 'SIG' => 1 ; }; -test 59, @warnings == 14 ; +test 59, @warnings == 15 ; test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/; +shift @warnings; #Constant subroutine BEGIN redefined at test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/; test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/; test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/; diff --git a/t/pragma/overload.t b/t/pragma/overload.t index f9a9c59c87..78ca147bf3 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -417,7 +417,7 @@ EOF m'try it'; s'first part'second part'; s/yet another/tail here/; - tr/z-Z/z-Z/; + tr/A-Z/a-z/; } test($out, '_<foo>_'); # 117 @@ -425,7 +425,7 @@ test($out1, '_<f\'o\\o>_'); # 128 test($out2, "_<a\a>_foo_<,\,>_"); # 129 test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups qq oups1 - q second part q tail here s z-Z tr z-Z tr"); # 130 + q second part q tail here s A-Z tr a-z tr"); # 130 test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 test($res, 1); # 132 test($a, "_<oups diff --git a/t/pragma/strict-vars b/t/pragma/strict-vars index 2ccfef7105..5ba579d969 100644 --- a/t/pragma/strict-vars +++ b/t/pragma/strict-vars @@ -387,6 +387,8 @@ EXPECT # multiple our declarations in same scope, same package, warning use strict 'vars'; use warnings; +{ our $x = 1 } +{ our $x = 0 } our $foo; { our $foo; @@ -394,6 +396,17 @@ our $foo; our $foo; } EXPECT -"our" variable $foo redeclared at - line 7. +"our" variable $foo redeclared at - line 9. (Did you mean "local" instead of "our"?) -Name "Foo::foo" used only once: possible typo at - line 9. +Name "Foo::foo" used only once: possible typo at - line 11. +######## + +# Make sure the strict vars failure still occurs +# now that the `@i should be written as \@i' failure does not occur +# 20000522 mjd@plover.com (MJD) +use strict 'vars'; +no warnings; +"@i_like_crackers"; +EXPECT +Global symbol "@i_like_crackers" requires explicit package name at - line 7. +Execution of - aborted due to compilation errors. diff --git a/t/pragma/strict.t b/t/pragma/strict.t index c4d64164e6..167b3604f5 100755 --- a/t/pragma/strict.t +++ b/t/pragma/strict.t @@ -19,7 +19,7 @@ my @prgs = () ; foreach (sort glob("pragma/strict-*")) { - next if /(~|\.orig)$/; + next if /(~|\.orig|,v)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; while (<F>) { diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t index 8db3d1a305..d1546feeaf 100755 --- a/t/pragma/utf8.t +++ b/t/pragma/utf8.t @@ -10,7 +10,7 @@ BEGIN { } } -print "1..65\n"; +print "1..66\n"; my $test = 1; @@ -289,3 +289,9 @@ sub ok_bytes { ok "\x{ab}" =~ /^\x{ab}$/, 1; $test++; # 65 } + +{ + use utf8; + ok_bytes chr(0xe2), pack("C*", 0xc3, 0xa2); + $test++; # 66 +} diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use index b489d62e19..e25d43adbb 100644 --- a/t/pragma/warn/2use +++ b/t/pragma/warn/2use @@ -13,25 +13,25 @@ BEGIN failed--compilation aborted at - line 3. ######## # Check compile time scope of pragma -use warnings 'deprecated' ; +use warnings 'syntax' ; { no warnings ; - 1 if $a EQ $b ; + my $a =+ 1 ; } -1 if $a EQ $b ; +my $a =+ 1 ; EXPECT -Use of EQ is deprecated at - line 8. +Reversed += operator at - line 8. ######## # Check compile time scope of pragma no warnings; { - use warnings 'deprecated' ; - 1 if $a EQ $b ; + use warnings 'syntax' ; + my $a =+ 1 ; } -1 if $a EQ $b ; +my $a =+ 1 ; EXPECT -Use of EQ is deprecated at - line 6. +Reversed += operator at - line 6. ######## # Check runtime scope of pragma @@ -67,55 +67,55 @@ EXPECT Use of uninitialized value in scalar chop at - line 6. ######## -use warnings 'deprecated' ; -1 if $a EQ $b ; +use warnings 'syntax' ; +my $a =+ 1 ; EXPECT -Use of EQ is deprecated at - line 3. +Reversed += operator at - line 3. ######## --FILE-- abc -1 if $a EQ $b ; +my $a =+ 1 ; 1; --FILE-- -use warnings 'deprecated' ; +use warnings 'syntax' ; require "./abc"; EXPECT ######## --FILE-- abc -use warnings 'deprecated' ; +use warnings 'syntax' ; 1; --FILE-- require "./abc"; -1 if $a EQ $b ; +my $a =+ 1 ; EXPECT ######## --FILE-- abc -use warnings 'deprecated' ; -1 if $a EQ $b ; +use warnings 'syntax' ; +my $a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; require "./abc"; my $a ; chop $a ; EXPECT -Use of EQ is deprecated at ./abc line 2. +Reversed += operator at ./abc line 2. Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm -use warnings 'deprecated' ; -1 if $a EQ $b ; +use warnings 'syntax' ; +my $a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; use abc; my $a ; chop $a ; EXPECT -Use of EQ is deprecated at abc.pm line 2. +Reversed += operator at abc.pm line 2. Use of uninitialized value in scalar chop at - line 3. ######## @@ -179,9 +179,9 @@ use warnings; { no warnings ; eval { - 1 if $a EQ $b ; + my $a =+ 1 ; }; print STDERR $@ ; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT @@ -192,41 +192,41 @@ use warnings; { no warnings ; eval { - use warnings 'deprecated' ; - 1 if $a EQ $b ; + use warnings 'syntax' ; + my $a =+ 1 ; }; print STDERR $@ ; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 8. +Reversed += operator at - line 8. ######## # Check scope of pragma with eval no warnings; { - use warnings 'deprecated' ; + use warnings 'syntax' ; eval { - 1 if $a EQ $b ; + my $a =+ 1 ; }; print STDERR $@ ; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 7. -Use of EQ is deprecated at - line 9. +Reversed += operator at - line 7. +Reversed += operator at - line 9. ######## # Check scope of pragma with eval no warnings; { - use warnings 'deprecated' ; + use warnings 'syntax' ; eval { no warnings ; - 1 if $a EQ $b ; + my $a =+ 1 ; }; print STDERR $@ ; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 10. +Reversed += operator at - line 10. ######## # Check scope of pragma with eval @@ -289,9 +289,9 @@ use warnings; { no warnings ; eval ' - 1 if $a EQ $b ; + my $a =+ 1 ; '; print STDERR $@ ; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT @@ -302,55 +302,53 @@ use warnings; { no warnings ; eval q[ - use warnings 'deprecated' ; - 1 if $a EQ $b ; + use warnings 'syntax' ; + my $a =+ 1 ; ]; print STDERR $@; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT -Use of EQ is deprecated at (eval 1) line 3. +Reversed += operator at (eval 1) line 3. ######## # Check scope of pragma with eval no warnings; { - use warnings 'deprecated' ; + use warnings 'syntax' ; eval ' - 1 if $a EQ $b ; + my $a =+ 1 ; '; print STDERR $@; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 9. -Use of EQ is deprecated at (eval 1) line 2. +Reversed += operator at - line 9. +Reversed += operator at (eval 1) line 2. ######## # Check scope of pragma with eval no warnings; { - use warnings 'deprecated' ; + use warnings 'syntax' ; eval ' no warnings ; - 1 if $a EQ $b ; + my $a =+ 1 ; '; print STDERR $@; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 10. +Reversed += operator at - line 10. ######## # Check the additive nature of the pragma -1 if $a EQ $b ; +my $a =+ 1 ; my $a ; chop $a ; -use warnings 'deprecated' ; -1 if $a EQ $b ; +use warnings 'syntax' ; +$a =+ 1 ; my $b ; chop $b ; use warnings 'uninitialized' ; my $c ; chop $c ; -no warnings 'deprecated' ; -1 if $a EQ $b ; +no warnings 'syntax' ; +$a =+ 1 ; EXPECT -Use of EQ is deprecated at - line 6. +Reversed += operator at - line 6. Use of uninitialized value in scalar chop at - line 9. -Use of uninitialized value in string eq at - line 11. -Use of uninitialized value in string eq at - line 11. diff --git a/t/pragma/warn/3both b/t/pragma/warn/3both index 335e1b26b7..a4d9ba806d 100644 --- a/t/pragma/warn/3both +++ b/t/pragma/warn/3both @@ -258,9 +258,9 @@ BEGIN { $^W = 1 } { no warnings ; eval ' - 1 if $a EQ $b ; + my $a =+ 1 ; '; print STDERR $@ ; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT diff --git a/t/pragma/warn/4lint b/t/pragma/warn/4lint index 56e3fabe2c..848822dd30 100644 --- a/t/pragma/warn/4lint +++ b/t/pragma/warn/4lint @@ -4,19 +4,19 @@ __END__ -W # lint: check compile time $^W is zapped BEGIN { $^W = 0 ;} -$a = $b = 1 ; -$a = 1 if $a EQ $b ; +$a = 1 ; +$a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT -Use of EQ is deprecated at - line 5. -print() on closed filehandle main::STDIN at - line 6. +Reversed += operator at - line 5. +print() on closed filehandle STDIN at - line 6. ######## -W # lint: check runtime $^W is zapped $^W = 0 ; close STDIN ; print STDIN "abc" ; EXPECT -print() on closed filehandle main::STDIN at - line 4. +print() on closed filehandle STDIN at - line 4. ######## -W # lint: check runtime $^W is zapped @@ -25,17 +25,17 @@ print() on closed filehandle main::STDIN at - line 4. close STDIN ; print STDIN "abc" ; } EXPECT -print() on closed filehandle main::STDIN at - line 5. +print() on closed filehandle STDIN at - line 5. ######## -W # lint: check "no warnings" is zapped no warnings ; -$a = $b = 1 ; -$a = 1 if $a EQ $b ; +$a = 1 ; +$a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT -Use of EQ is deprecated at - line 5. -print() on closed filehandle main::STDIN at - line 6. +Reversed += operator at - line 5. +print() on closed filehandle STDIN at - line 6. ######## -W # lint: check "no warnings" is zapped @@ -44,7 +44,7 @@ print() on closed filehandle main::STDIN at - line 6. close STDIN ; print STDIN "abc" ; } EXPECT -print() on closed filehandle main::STDIN at - line 5. +print() on closed filehandle STDIN at - line 5. ######## -Ww # lint: check combination of -w and -W @@ -53,62 +53,62 @@ print() on closed filehandle main::STDIN at - line 5. close STDIN ; print STDIN "abc" ; } EXPECT -print() on closed filehandle main::STDIN at - line 5. +print() on closed filehandle STDIN at - line 5. ######## -W --FILE-- abc.pm -no warnings 'deprecated' ; -my ($a, $b) = (0,0); -1 if $a EQ $b ; +no warnings 'syntax' ; +my $a = 0; +$a =+ 1 ; 1; --FILE-- no warnings 'uninitialized' ; use abc; my $a ; chop $a ; EXPECT -Use of EQ is deprecated at abc.pm line 3. +Reversed += operator at abc.pm line 3. Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc -no warnings 'deprecated' ; -my ($a, $b) = (0,0); -1 if $a EQ $b ; +no warnings 'syntax' ; +my $a = 0; +$a =+ 1 ; 1; --FILE-- no warnings 'uninitialized' ; require "./abc"; my $a ; chop $a ; EXPECT -Use of EQ is deprecated at ./abc line 3. +Reversed += operator at ./abc line 3. Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc.pm BEGIN {$^W = 0} -my ($a, $b) = (0,0); -1 if $a EQ $b ; +my $a = 0 ; +$a =+ 1 ; 1; --FILE-- $^W = 0 ; use abc; my $a ; chop $a ; EXPECT -Use of EQ is deprecated at abc.pm line 3. +Reversed += operator at abc.pm line 3. Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc BEGIN {$^W = 0} -my ($a, $b) = (0,0); -1 if $a EQ $b ; +my $a = 0 ; +$a =+ 1 ; 1; --FILE-- $^W = 0 ; require "./abc"; my $a ; chop $a ; EXPECT -Use of EQ is deprecated at ./abc line 3. +Reversed += operator at ./abc line 3. Use of uninitialized value in scalar chop at - line 3. ######## -W @@ -175,42 +175,42 @@ use warnings; my $a = "1"; my $b = "2"; no warnings ; eval q[ - use warnings 'deprecated' ; - 1 if $a EQ $b ; + use warnings 'syntax' ; + $a =+ 1 ; ]; print STDERR $@; - 1 if $a EQ $b ; + $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 11. -Use of EQ is deprecated at (eval 1) line 3. +Reversed += operator at - line 11. +Reversed += operator at (eval 1) line 3. ######## -W # Check scope of pragma with eval no warnings; { my $a = "1"; my $b = "2"; - use warnings 'deprecated' ; + use warnings 'syntax' ; eval ' - 1 if $a EQ $b ; + $a =+ 1 ; '; print STDERR $@; - 1 if $a EQ $b ; + $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 10. -Use of EQ is deprecated at (eval 1) line 2. +Reversed += operator at - line 10. +Reversed += operator at (eval 1) line 2. ######## -W # Check scope of pragma with eval no warnings; { my $a = "1"; my $b = "2"; - use warnings 'deprecated' ; + use warnings 'syntax' ; eval ' no warnings ; - 1 if $a EQ $b ; + $a =+ 1 ; '; print STDERR $@; - 1 if $a EQ $b ; + $a =+ 1 ; } EXPECT -Use of EQ is deprecated at - line 11. -Use of EQ is deprecated at (eval 1) line 3. +Reversed += operator at - line 11. +Reversed += operator at (eval 1) line 3. diff --git a/t/pragma/warn/5nolint b/t/pragma/warn/5nolint index 2459968003..56158a20be 100644 --- a/t/pragma/warn/5nolint +++ b/t/pragma/warn/5nolint @@ -1,11 +1,11 @@ -Check anti-lint +syntax anti-lint __END__ -X # nolint: check compile time $^W is zapped BEGIN { $^W = 1 ;} $a = $b = 1 ; -$a = 1 if $a EQ $b ; +$a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT ######## @@ -27,7 +27,7 @@ EXPECT # nolint: check "no warnings" is zapped use warnings ; $a = $b = 1 ; -$a = 1 if $a EQ $b ; +$a =+ 1 ; close STDIN ; print STDIN "abc" ; EXPECT ######## @@ -49,9 +49,9 @@ EXPECT ######## -X --FILE-- abc.pm -use warnings 'deprecated' ; -my ($a, $b) = (0,0); -1 if $a EQ $b ; +use warnings 'syntax' ; +my $a = 0; +$a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; @@ -61,9 +61,9 @@ EXPECT ######## -X --FILE-- abc -use warnings 'deprecated' ; -my ($a, $b) = (0,0); -1 if $a EQ $b ; +use warnings 'syntax' ; +my $a = 0; +$a =+ 1 ; 1; --FILE-- use warnings 'uninitialized' ; @@ -75,7 +75,7 @@ EXPECT --FILE-- abc.pm BEGIN {$^W = 1} my ($a, $b) = (0,0); -1 if $a EQ $b ; +$a =+ 1 ; 1; --FILE-- $^W = 1 ; @@ -87,7 +87,7 @@ EXPECT --FILE-- abc BEGIN {$^W = 1} my ($a, $b) = (0,0); -1 if $a EQ $b ; +$a =+ 1 ; 1; --FILE-- $^W = 1 ; @@ -155,9 +155,9 @@ use warnings; { no warnings ; eval ' - 1 if $a EQ $b ; + my $a =+ 1 ; '; print STDERR $@ ; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT @@ -168,10 +168,10 @@ use warnings; { no warnings ; eval q[ - use warnings 'deprecated' ; - 1 if $a EQ $b ; + use warnings 'syntax' ; + my $a =+ 1 ; ]; print STDERR $@; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT @@ -180,11 +180,11 @@ EXPECT # Check scope of pragma with eval no warnings; { - use warnings 'deprecated' ; + use warnings 'syntax' ; eval ' - 1 if $a EQ $b ; + my $a =+ 1 ; '; print STDERR $@; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT @@ -193,12 +193,12 @@ EXPECT # Check scope of pragma with eval no warnings; { - use warnings 'deprecated' ; + use warnings 'syntax' ; eval ' no warnings ; - 1 if $a EQ $b ; + my $a =+ 1 ; '; print STDERR $@; - 1 if $a EQ $b ; + my $a =+ 1 ; } EXPECT diff --git a/t/pragma/warn/7fatal b/t/pragma/warn/7fatal index 2d29ddbd82..382a8458e5 100644 --- a/t/pragma/warn/7fatal +++ b/t/pragma/warn/7fatal @@ -3,27 +3,27 @@ Check FATAL functionality __END__ # Check compile time warning -use warnings FATAL => 'deprecated' ; +use warnings FATAL => 'syntax' ; { no warnings ; - 1 if $a EQ $b ; + $a =+ 1 ; } -1 if $a EQ $b ; +$a =+ 1 ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at - line 8. +Reversed += operator at - line 8. ######## # Check compile time warning use warnings FATAL => 'all' ; { no warnings ; - 1 if $a EQ $b ; + my $a =+ 1 ; } -1 if $a EQ $b ; +my $a =+ 1 ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at - line 8. +Reversed += operator at - line 8. ######## # Check runtime scope of pragma @@ -75,28 +75,28 @@ Use of uninitialized value in scalar chop at - line 6. ######## --FILE-- abc -1 if $a EQ $b ; +$a =+ 1 ; 1; --FILE-- -use warnings FATAL => 'deprecated' ; +use warnings FATAL => 'syntax' ; require "./abc"; EXPECT ######## --FILE-- abc -use warnings FATAL => 'deprecated' ; +use warnings FATAL => 'syntax' ; 1; --FILE-- require "./abc"; -1 if $a EQ $b ; +$a =+ 1 ; EXPECT ######## --FILE-- abc -use warnings 'deprecated' ; -1 if $a EQ $b ; +use warnings 'syntax' ; +$a =+ 1 ; 1; --FILE-- use warnings FATAL => 'uninitialized' ; @@ -104,13 +104,13 @@ require "./abc"; my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at ./abc line 2. +Reversed += operator at ./abc line 2. Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm -use warnings 'deprecated' ; -1 if $a EQ $b ; +use warnings 'syntax' ; +$a =+ 1 ; 1; --FILE-- use warnings FATAL => 'uninitialized' ; @@ -118,7 +118,7 @@ use abc; my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at abc.pm line 2. +Reversed += operator at abc.pm line 2. Use of uninitialized value in scalar chop at - line 3. ######## @@ -162,44 +162,44 @@ Use of uninitialized value in scalar chop at - line 8. # Check scope of pragma with eval no warnings ; eval { - use warnings FATAL => 'deprecated' ; - 1 if $a EQ $b ; + use warnings FATAL => 'syntax' ; + $a =+ 1 ; }; print STDERR "-- $@" ; -1 if $a EQ $b ; +$a =+ 1 ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at - line 6. +Reversed += operator at - line 6. ######## # Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; +use warnings FATAL => 'syntax' ; eval { - 1 if $a EQ $b ; + $a =+ 1 ; }; print STDERR "-- $@" ; -1 if $a EQ $b ; +$a =+ 1 ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at - line 5. +Reversed += operator at - line 5. ######## # Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; +use warnings FATAL => 'syntax' ; eval { no warnings ; - 1 if $a EQ $b ; + $a =+ 1 ; }; print STDERR $@ ; -1 if $a EQ $b ; +$a =+ 1 ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at - line 8. +Reversed += operator at - line 8. ######## # Check scope of pragma with eval no warnings ; eval { - use warnings FATAL => 'deprecated' ; + use warnings FATAL => 'syntax' ; }; print STDERR $@ ; -1 if $a EQ $b ; +$a =+ 1 ; print STDERR "The End.\n" ; EXPECT The End. @@ -245,34 +245,34 @@ Use of uninitialized value in scalar chop at - line 8. # Check scope of pragma with eval no warnings ; eval q[ - use warnings FATAL => 'deprecated' ; - 1 if $a EQ $b ; + use warnings FATAL => 'syntax' ; + $a =+ 1 ; ]; print STDERR "-- $@"; -1 if $a EQ $b ; +$a =+ 1 ; print STDERR "The End.\n" ; EXPECT --- Use of EQ is deprecated at (eval 1) line 3. +-- Reversed += operator at (eval 1) line 3. The End. ######## # Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; +use warnings FATAL => 'syntax' ; eval ' - 1 if $a EQ $b ; + $a =+ 1 ; '; print STDERR "-- $@"; print STDERR "The End.\n" ; EXPECT --- Use of EQ is deprecated at (eval 1) line 2. +-- Reversed += operator at (eval 1) line 2. The End. ######## # Check scope of pragma with eval -use warnings FATAL => 'deprecated' ; +use warnings FATAL => 'syntax' ; eval ' no warnings ; - 1 if $a EQ $b ; + $a =+ 1 ; '; print STDERR "-- $@"; -1 if $a EQ $b ; +$a =+ 1 ; print STDERR "The End.\n" ; EXPECT -Use of EQ is deprecated at - line 8. +Reversed += operator at - line 8. diff --git a/t/pragma/warn/8signal b/t/pragma/warn/8signal index d480f1902a..cc1b9d926d 100644 --- a/t/pragma/warn/8signal +++ b/t/pragma/warn/8signal @@ -6,13 +6,13 @@ __END__ # 8signal BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } } BEGIN { $SIG{__DIE__} = sub { print "DIE -- @_" } } -1 if 1 EQ 2 ; -use warnings qw(deprecated) ; -1 if 1 EQ 2 ; -use warnings FATAL => qw(deprecated) ; -1 if 1 EQ 2 ; +$a =+ 1 ; +use warnings qw(syntax) ; +$a =+ 1 ; +use warnings FATAL => qw(syntax) ; +$a =+ 1 ; print "The End.\n" ; EXPECT -WARN -- Use of EQ is deprecated at - line 6. -DIE -- Use of EQ is deprecated at - line 8. -Use of EQ is deprecated at - line 8. +WARN -- Reversed += operator at - line 6. +DIE -- Reversed += operator at - line 8. +Reversed += operator at - line 8. diff --git a/t/pragma/warn/9enabled b/t/pragma/warn/9enabled index 55642ffadf..96f319e55d 100755 --- a/t/pragma/warn/9enabled +++ b/t/pragma/warn/9enabled @@ -817,3 +817,87 @@ abc all not enabled def self enabled def abc not enabled def all not enabled +######## +-w +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## +-w +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +BEGIN { $^W = 1 ; } +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +$^W = 1 ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index bd409721d2..813f149fb5 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -12,7 +12,7 @@ warn(warn_nl, "open"); [Perl_do_open9] open(F, "true\ncd") - Close on unopened file <%s> [Perl_do_close] <<TODO + Close on unopened file %s [Perl_do_close] <<TODO $a = "fred";close("$a") tell() on unopened file [Perl_do_tell] @@ -96,7 +96,7 @@ close "fred" ; no warnings 'unopened' ; close "joe" ; EXPECT -Close on unopened file <fred> at - line 3. +Close on unopened file fred at - line 3. ######## # doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat] use warnings 'io' ; @@ -115,7 +115,7 @@ EXPECT tell() on unopened file at - line 4. seek() on unopened file at - line 5. sysseek() on unopened file at - line 6. -Stat on unopened file <STDIN> at - line 7. +Stat on unopened file STDIN at - line 7. ######## # doio.c [Perl_do_print] use warnings 'uninitialized' ; @@ -188,4 +188,4 @@ my $a = eof STDOUT ; no warnings 'io' ; $a = eof STDOUT ; EXPECT -Filehandle main::STDOUT opened only for output at - line 3. +Filehandle STDOUT opened only for output at - line 3. diff --git a/t/pragma/warn/op b/t/pragma/warn/op index 2c9e0fdbed..de326f8b0c 100644 --- a/t/pragma/warn/op +++ b/t/pragma/warn/op @@ -278,7 +278,7 @@ Useless use of hash element in void context at - line 29. Useless use of hash slice in void context at - line 30. Useless use of unpack in void context at - line 31. Useless use of pack in void context at - line 32. -Useless use of join in void context at - line 33. +Useless use of join or string in void context at - line 33. Useless use of list slice in void context at - line 34. Useless use of sort in void context at - line 37. Useless use of reverse in void context at - line 38. @@ -716,6 +716,20 @@ EXPECT Constant subroutine fred redefined at - line 4. ######## # op.c +no warnings 'redefine' ; +sub fred () { 1 } +sub fred () { 2 } +EXPECT +Constant subroutine fred redefined at - line 4. +######## +# op.c +no warnings 'redefine' ; +sub fred () { 1 } +*fred = sub () { 2 }; +EXPECT +Constant subroutine fred redefined at - line 4. +######## +# op.c use warnings 'redefine' ; format FRED = . diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 275905749e..fe874ef7ef 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -52,7 +52,7 @@ print $f $a; no warnings 'unopened' ; print $f $a; EXPECT -Filehandle main::abc never opened at - line 4. +Filehandle abc never opened at - line 4. ######## # pp_hot.c [pp_print] use warnings 'io' ; @@ -71,12 +71,12 @@ print getc(FOO); no warnings 'io' ; print STDIN "anc"; EXPECT -Filehandle main::STDIN opened only for input at - line 3. -Filehandle main::STDOUT opened only for output at - line 4. -Filehandle main::STDERR opened only for output at - line 5. -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. +Filehandle STDIN opened only for input at - line 3. +Filehandle STDOUT opened only for output at - line 4. +Filehandle STDERR opened only for output at - line 5. +Filehandle FOO opened only for output at - line 6. +Filehandle STDERR opened only for output at - line 7. +Filehandle FOO opened only for output at - line 8. ######## # pp_hot.c [pp_print] use warnings 'closed' ; @@ -90,9 +90,9 @@ print STDIN "anc"; opendir STDIN, "."; print STDIN "anc"; EXPECT -print() on closed filehandle main::STDIN at - line 4. -print() on closed filehandle main::STDIN at - line 6. - (Are you trying to call print() on dirhandle main::STDIN?) +print() on closed filehandle STDIN at - line 4. +print() on closed filehandle STDIN at - line 6. + (Are you trying to call print() on dirhandle STDIN?) ######## # pp_hot.c [pp_rv2av] use warnings 'uninitialized' ; @@ -137,9 +137,9 @@ no warnings 'closed' ; opendir STDIN, "." ; $a = <STDIN> ; $a = <STDIN> ; EXPECT -readline() on closed filehandle main::STDIN at - line 3. -readline() on closed filehandle main::STDIN at - line 4. - (Are you trying to call readline() on dirhandle main::STDIN?) +readline() on closed filehandle STDIN at - line 3. +readline() on closed filehandle STDIN at - line 4. + (Are you trying to call readline() on dirhandle STDIN?) ######## # pp_hot.c [Perl_do_readline] use warnings 'io' ; @@ -150,7 +150,7 @@ no warnings 'io' ; $a = <FH> ; unlink $file ; EXPECT -Filehandle main::FH opened only for output at - line 5. +Filehandle FH opened only for output at - line 5. ######## # pp_hot.c [Perl_sub_crush_depth] use warnings 'recursion' ; diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 7c38727e28..ad5982ab81 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -107,7 +107,7 @@ write STDIN; no warnings 'io' ; write STDIN; EXPECT -Filehandle main::STDIN opened only for input at - line 5. +Filehandle STDIN opened only for input at - line 5. ######## # pp_sys.c [pp_leavewrite] use warnings 'closed' ; @@ -123,9 +123,9 @@ write STDIN; opendir STDIN, "."; write STDIN; EXPECT -write() on closed filehandle main::STDIN at - line 6. -write() on closed filehandle main::STDIN at - line 8. - (Are you trying to call write() on dirhandle main::STDIN?) +write() on closed filehandle STDIN at - line 6. +write() on closed filehandle STDIN at - line 8. + (Are you trying to call write() on dirhandle STDIN?) ######## # pp_sys.c [pp_leavewrite] use warnings 'io' ; @@ -152,7 +152,7 @@ printf $a "fred"; no warnings 'unopened' ; printf $a "fred"; EXPECT -Filehandle main::abc never opened at - line 4. +Filehandle abc never opened at - line 4. ######## # pp_sys.c [pp_prtf] use warnings 'closed' ; @@ -166,9 +166,9 @@ printf STDIN "fred"; opendir STDIN, "."; printf STDIN "fred"; EXPECT -printf() on closed filehandle main::STDIN at - line 4. -printf() on closed filehandle main::STDIN at - line 6. - (Are you trying to call printf() on dirhandle main::STDIN?) +printf() on closed filehandle STDIN at - line 4. +printf() on closed filehandle STDIN at - line 6. + (Are you trying to call printf() on dirhandle STDIN?) ######## # pp_sys.c [pp_prtf] use warnings 'io' ; @@ -176,7 +176,7 @@ printf STDIN "fred"; no warnings 'io' ; printf STDIN "fred"; EXPECT -Filehandle main::STDIN opened only for input at - line 3. +Filehandle STDIN opened only for input at - line 3. ######## # pp_sys.c [pp_send] use warnings 'closed' ; @@ -190,9 +190,9 @@ syswrite STDIN, "fred", 1; opendir STDIN, "."; syswrite STDIN, "fred", 1; EXPECT -syswrite() on closed filehandle main::STDIN at - line 4. -syswrite() on closed filehandle main::STDIN at - line 6. - (Are you trying to call syswrite() on dirhandle main::STDIN?) +syswrite() on closed filehandle STDIN at - line 4. +syswrite() on closed filehandle STDIN at - line 6. + (Are you trying to call syswrite() on dirhandle STDIN?) ######## # pp_sys.c [pp_flock] use Config; @@ -215,9 +215,9 @@ flock STDIN, 8; opendir STDIN, "."; flock STDIN, 8; EXPECT -flock() on closed filehandle main::STDIN at - line 14. -flock() on closed filehandle main::STDIN at - line 16. - (Are you trying to call flock() on dirhandle main::STDIN?) +flock() on closed filehandle STDIN at - line 14. +flock() on closed filehandle STDIN at - line 16. + (Are you trying to call flock() on dirhandle STDIN?) ######## # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] use warnings 'io' ; @@ -285,36 +285,36 @@ getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; EXPECT -send() on closed socket main::STDIN at - line 22. -bind() on closed socket main::STDIN at - line 23. -connect() on closed socket main::STDIN at - line 24. -listen() on closed socket main::STDIN at - line 25. -accept() on closed socket main::STDIN at - line 26. -shutdown() on closed socket main::STDIN at - line 27. -setsockopt() on closed socket main::STDIN at - line 28. -getsockopt() on closed socket main::STDIN at - line 29. -getsockname() on closed socket main::STDIN at - line 30. -getpeername() on closed socket main::STDIN at - line 31. -send() on closed socket main::STDIN at - line 33. - (Are you trying to call send() on dirhandle main::STDIN?) -bind() on closed socket main::STDIN at - line 34. - (Are you trying to call bind() on dirhandle main::STDIN?) -connect() on closed socket main::STDIN at - line 35. - (Are you trying to call connect() on dirhandle main::STDIN?) -listen() on closed socket main::STDIN at - line 36. - (Are you trying to call listen() on dirhandle main::STDIN?) -accept() on closed socket main::STDIN at - line 37. - (Are you trying to call accept() on dirhandle main::STDIN?) -shutdown() on closed socket main::STDIN at - line 38. - (Are you trying to call shutdown() on dirhandle main::STDIN?) -setsockopt() on closed socket main::STDIN at - line 39. - (Are you trying to call setsockopt() on dirhandle main::STDIN?) -getsockopt() on closed socket main::STDIN at - line 40. - (Are you trying to call getsockopt() on dirhandle main::STDIN?) -getsockname() on closed socket main::STDIN at - line 41. - (Are you trying to call getsockname() on dirhandle main::STDIN?) -getpeername() on closed socket main::STDIN at - line 42. - (Are you trying to call getpeername() on dirhandle main::STDIN?) +send() on closed socket STDIN at - line 22. +bind() on closed socket STDIN at - line 23. +connect() on closed socket STDIN at - line 24. +listen() on closed socket STDIN at - line 25. +accept() on closed socket STDIN at - line 26. +shutdown() on closed socket STDIN at - line 27. +setsockopt() on closed socket STDIN at - line 28. +getsockopt() on closed socket STDIN at - line 29. +getsockname() on closed socket STDIN at - line 30. +getpeername() on closed socket STDIN at - line 31. +send() on closed socket STDIN at - line 33. + (Are you trying to call send() on dirhandle STDIN?) +bind() on closed socket STDIN at - line 34. + (Are you trying to call bind() on dirhandle STDIN?) +connect() on closed socket STDIN at - line 35. + (Are you trying to call connect() on dirhandle STDIN?) +listen() on closed socket STDIN at - line 36. + (Are you trying to call listen() on dirhandle STDIN?) +accept() on closed socket STDIN at - line 37. + (Are you trying to call accept() on dirhandle STDIN?) +shutdown() on closed socket STDIN at - line 38. + (Are you trying to call shutdown() on dirhandle STDIN?) +setsockopt() on closed socket STDIN at - line 39. + (Are you trying to call setsockopt() on dirhandle STDIN?) +getsockopt() on closed socket STDIN at - line 40. + (Are you trying to call getsockopt() on dirhandle STDIN?) +getsockname() on closed socket STDIN at - line 41. + (Are you trying to call getsockname() on dirhandle STDIN?) +getpeername() on closed socket STDIN at - line 42. + (Are you trying to call getpeername() on dirhandle STDIN?) ######## # pp_sys.c [pp_stat] use warnings 'newline' ; @@ -331,7 +331,7 @@ close STDIN ; no warnings 'unopened' ; -T STDIN ; EXPECT -Test on unopened file <STDIN> at - line 4. +Test on unopened file STDIN at - line 4. ######## # pp_sys.c [pp_fttext] use warnings 'newline' ; @@ -351,4 +351,4 @@ my $a = sysread(F, $a,10) ; close F ; unlink $file ; EXPECT -Filehandle main::F opened only for output at - line 5. +Filehandle F opened only for output at - line 5. diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index 5d0c291ea0..ef87b7fbb4 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -11,10 +11,6 @@ Character class [:%.*s:] unknown [S_regpposixcc] - 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] /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] @@ -58,32 +54,37 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } use warnings 'regexp' ; $_ = "" ; /[:alpha:]/; -/[.bar.]/; -/[=zog=]/; -/[[:alpha:]]/; -/[[.foo.]]/; -/[[=bar=]]/; /[:zog:]/; /[[:zog:]]/; no warnings 'regexp' ; /[:alpha:]/; -/[.foo.]/; -/[=bar=]/; -/[[:alpha:]]/; -/[[.foo.]]/; -/[[=bar=]]/; -/[[:zog:]]/; /[:zog:]/; +/[[:zog:]]/; EXPECT Character class syntax [: :] belongs inside character classes at - line 5. -Character class syntax [. .] belongs inside character classes at - line 6. -Character class syntax [. .] is reserved for future extensions at - line 6. -Character class syntax [= =] belongs inside character classes at - line 7. -Character class syntax [= =] is reserved for future extensions at - line 7. -Character class syntax [. .] is reserved for future extensions at - line 9. -Character class syntax [= =] is reserved for future extensions at - line 10. -Character class syntax [: :] belongs inside character classes at - line 11. -Character class [:zog:] unknown at - line 12. +Character class syntax [: :] belongs inside character classes at - line 6. +Character class [:zog:] unknown at - line 7. +######## +# regcomp.c [S_checkposixcc] +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } +use warnings 'regexp' ; +$_ = "" ; +/[.zog.]/; +no warnings 'regexp' ; +/[.zog.]/; +EXPECT +Character class syntax [. .] belongs inside character classes at - line 5. +Character class syntax [. .] is reserved for future extensions at - line 5. +######## +# regcomp.c [S_checkposixcc] +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } +use warnings 'regexp' ; +$_ = "" ; +/[[.zog.]]/; +no warnings 'regexp' ; +/[[.zog.]]/; +EXPECT +Character class syntax [. .] is reserved for future extensions at - line 5. ######## # regcomp.c [S_regclass] $_ = ""; diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index 758137f2e8..2409589a8f 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -178,7 +178,7 @@ no warnings 'uninitialized' ; $C = "" ; $C .= $A ; EXPECT -Use of uninitialized value in concatenation (.) at - line 10. +Use of uninitialized value in concatenation (.) or string at - line 10. ######## # sv.c use warnings 'numeric' ; diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index 8db8027767..2c9433bd7d 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -3,12 +3,6 @@ toke.c AOK we seem to have lost a few ambiguous warnings!! - 1 if $a EQ $b ; - 1 if $a NE $b ; - 1 if $a LT $b ; - 1 if $a GT $b ; - 1 if $a GE $b ; - 1 if $a LE $b ; $a = <<; Use of comma-less variable list is deprecated (called 3 times via depcom) @@ -132,29 +126,6 @@ toke.c AOK __END__ # toke.c use warnings 'deprecated' ; -1 if $a EQ $b ; -1 if $a NE $b ; -1 if $a GT $b ; -1 if $a LT $b ; -1 if $a GE $b ; -1 if $a LE $b ; -no warnings 'deprecated' ; -1 if $a EQ $b ; -1 if $a NE $b ; -1 if $a GT $b ; -1 if $a LT $b ; -1 if $a GE $b ; -1 if $a LE $b ; -EXPECT -Use of EQ is deprecated at - line 3. -Use of NE is deprecated at - line 4. -Use of GT is deprecated at - line 5. -Use of LT is deprecated at - line 6. -Use of GE is deprecated at - line 7. -Use of LE is deprecated at - line 8. -######## -# toke.c -use warnings 'deprecated' ; format STDOUT = @<<< @||| @>>> @>>> $a $b "abc" 'def' @@ -585,3 +556,11 @@ 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. +######## +# toke.c +use warnings 'ambiguous'; +"@mjd_previously_unused_array"; +no warnings 'ambiguous'; +"@mjd_previously_unused_array"; +EXPECT +Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. diff --git a/t/pragma/warnings.t b/t/pragma/warnings.t index 71fb0df972..a551740b17 100644 --- a/t/pragma/warnings.t +++ b/t/pragma/warnings.t @@ -26,9 +26,7 @@ else foreach (@w_files) { - next if /\.orig$/ ; - - next if /(~|\.orig)$/; + next if /(~|\.orig|,v)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; while (<F>) { |