diff options
Diffstat (limited to 't')
36 files changed, 1163 insertions, 291 deletions
@@ -12,6 +12,10 @@ use Config; $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2' or $^O eq 'mint'); +if (defined &Win32::IsWinNT && Win32::IsWinNT()) { + $Is_Dosish = '' if Win32::FsType() eq 'NTFS'; +} + print "1..28\n"; $wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); @@ -54,28 +58,35 @@ elsif (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";} -if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} +$newmode = $^O eq 'MSWin32' ? 0444 : 0777; +if ((chmod $newmode,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); if ($Is_Dosish) {print "ok 7 # skipped: no link\n";} -elsif (($mode & 0777) == 0777) {print "ok 7\n";} +elsif (($mode & 0777) == $newmode) {print "ok 7\n";} else {print "not ok 7\n";} +$newmode = 0700; +if ($^O eq 'MSWin32') { + chmod 0444, 'x'; + $newmode = 0666; +} + if ($Is_Dosish) {print "ok 8 # skipped: no link\n";} -elsif ((chmod 0700,'c','x') == 2) {print "ok 8\n";} +elsif ((chmod $newmode,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('c'); if ($Is_Dosish) {print "ok 9 # skipped: no link\n";} -elsif (($mode & 0777) == 0700) {print "ok 9\n";} +elsif (($mode & 0777) == $newmode) {print "ok 9\n";} else {print "not ok 9\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('x'); if ($Is_Dosish) {print "ok 10 # skipped: no link\n";} -elsif (($mode & 0777) == 0700) {print "ok 10\n";} +elsif (($mode & 0777) == $newmode) {print "ok 10\n";} else {print "not ok 10\n";} if ($Is_Dosish) {print "ok 11 # skipped: no link\n"; unlink 'b','x'; } diff --git a/t/io/nargv.t b/t/io/nargv.t new file mode 100755 index 0000000000..fb13857618 --- /dev/null +++ b/t/io/nargv.t @@ -0,0 +1,63 @@ +#!./perl + +print "1..5\n"; + +my $j = 1; +for $i ( 1,2,5,4,3 ) { + $file = mkfiles($i); + open(FH, "> $file") || die "can't create $file: $!"; + print FH "not ok " . $j++ . "\n"; + close(FH) || die "Can't close $file: $!"; +} + + +{ + local *ARGV; + local $^I = '.bak'; + local $_; + @ARGV = mkfiles(1..3); + $n = 0; + while (<>) { + print STDOUT "# initial \@ARGV: [@ARGV]\n"; + if ($n++ == 2) { + other(); + } + show(); + } +} + +$^I = undef; +@ARGV = mkfiles(1..3); +$n = 0; +while (<>) { + print STDOUT "#final \@ARGV: [@ARGV]\n"; + if ($n++ == 2) { + other(); + } + show(); +} + +sub show { + #warn "$ARGV: $_"; + s/^not //; + print; +} + +sub other { + print STDOUT "# Calling other\n"; + local *ARGV; + local *ARGVOUT; + local $_; + @ARGV = mkfiles(5, 4); + while (<>) { + print STDOUT "# inner \@ARGV: [@ARGV]\n"; + show(); + } +} + +sub mkfiles { + my @files = map { "scratch$_" } @_; + return wantarray ? @files : $files[-1]; +} + +END { unlink map { ($_, "$_.bak") } mkfiles(1..5) } diff --git a/t/io/open.t b/t/io/open.t index 418edacf39..f8c7213baf 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -5,110 +5,256 @@ $| = 1; $^W = 1; $Is_VMS = $^O eq 'VMS'; -print "1..32\n"; +print "1..64\n"; + +my $test = 1; + +sub ok { print "ok $test\n"; $test++ } # my $file tests +# 1..9 { -unlink("afile") if -f "afile"; -print "$!\nnot " unless open(my $f,"+>afile"); -print "ok 1\n"; -binmode $f; -print "not " unless -f "afile"; -print "ok 2\n"; -print "not " unless print $f "SomeData\n"; -print "ok 3\n"; -print "not " unless tell($f) == 9; -print "ok 4\n"; -print "not " unless seek($f,0,0); -print "ok 5\n"; -$b = <$f>; -print "not " unless $b eq "SomeData\n"; -print "ok 6\n"; -print "not " unless -f $f; -print "ok 7\n"; -eval { die "Message" }; -# warn $@; -print "not " unless $@ =~ /<\$f> line 1/; -print "ok 8\n"; -print "not " unless close($f); -print "ok 9\n"; -unlink("afile"); + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(my $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); } + +# 10..12 { -print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); -print "ok 10\n"; -print $f "a row\n"; -print "not " unless close($f); -print "ok 11\n"; -print "not " unless -s 'afile' < 10; -print "ok 12\n"; + print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; } + +# 13..15 { -print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); -print "ok 13\n"; -print $f "a row\n"; -print "not " unless close($f); -print "ok 14\n"; -print "not " unless -s 'afile' > 10; -print "ok 15\n"; + print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; } + +# 16..18 { -print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); -print "ok 16\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 17\n"; -print "not " unless close($f); -print "ok 18\n"; + print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; } + +# 19..23 { -print "not " unless -s 'afile' < 20; -print "ok 19\n"; -print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); -print "ok 20\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 21\n"; -seek $f, 0, 1; -print $f "yet another row\n"; -print "not " unless close($f); -print "ok 22\n"; -print "not " unless -s 'afile' > 20; -print "ok 23\n"; - -unlink("afile"); -} -if ($Is_VMS) { for (24..46) { print "ok $_ # skipped: not Unix fork\n"; } } + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 24..26 +if ($Is_VMS) { + for (24..26) { print "ok $_ # skipped: not Unix fork\n"; } +} else { -print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); -./perl -e "print qq(a row\n); print qq(another row\n)" + print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" EOC -print "ok 24\n"; -@rows = <$f>; -print "not " unless @rows == 2; -print "ok 25\n"; -print "not " unless close($f); -print "ok 26\n"; -} -if ($Is_VMS) { for (27..30) { print "OK $_ # skipped: not Unix fork\n"; } } + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 27..30 +if ($Is_VMS) { + for (27..30) { print "ok $_ # skipped: not Unix fork\n"; } +} else { -print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); -./perl -pe "s/^not //" + print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" EOC -print "ok 27\n"; -@rows = <$f>; -print $f "not ok 28\n"; -print $f "not ok 29\n"; -print "#\nnot " unless close($f); -sleep 1; -print "ok 30\n"; + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; } +# 31..32 eval <<'EOE' and print "not "; open my $f, '<&', 'afile'; 1; EOE -print "ok 31\n"; +ok; +$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; +ok; + +# local $file tests + +# 33..41 +{ + unlink("afile") if -f "afile"; + print "$!\nnot " unless open(local $f,"+>afile"); + ok; + binmode $f; + print "not " unless -f "afile"; + ok; + print "not " unless print $f "SomeData\n"; + ok; + print "not " unless tell($f) == 9; + ok; + print "not " unless seek($f,0,0); + ok; + $b = <$f>; + print "not " unless $b eq "SomeData\n"; + ok; + print "not " unless -f $f; + ok; + eval { die "Message" }; + # warn $@; + print "not " unless $@ =~ /<\$f> line 1/; + ok; + print "not " unless close($f); + ok; + unlink("afile"); +} + +# 42..44 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' < 10; + ok; +} + +# 45..47 +{ + print "# \$!='$!'\nnot " unless open(local $f,'>>', 'afile'); + ok; + print $f "a row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 10; + ok; +} + +# 48..50 +{ + print "# \$!='$!'\nnot " unless open(local $f, '<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 51..55 +{ + print "not " unless -s 'afile' < 20; + ok; + print "# \$!='$!'\nnot " unless open(local $f, '+<', 'afile'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + seek $f, 0, 1; + print $f "yet another row\n"; + print "not " unless close($f); + ok; + print "not " unless -s 'afile' > 20; + ok; + + unlink("afile"); +} + +# 56..58 +if ($Is_VMS) { + for (56..58) { print "ok $_ # skipped: not Unix fork\n"; } +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '-|', <<'EOC'); + ./perl -e "print qq(a row\n); print qq(another row\n)" +EOC + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 59..62 +if ($Is_VMS) { + for (59..62) { print "ok $_ # skipped: not Unix fork\n"; } +} +else { + print "# \$!='$!'\nnot " unless open(local $f, '|-', <<'EOC'); + ./perl -pe "s/^not //" +EOC + ok; + @rows = <$f>; + print $f "not ok $test\n"; $test++; + print $f "not ok $test\n"; $test++; + print "#\nnot " unless close($f); + sleep 1; + ok; +} + +# 63..64 +eval <<'EOE' and print "not "; +open local $f, '<&', 'afile'; +1; +EOE +ok; $@ =~ /Unknown open\(\) mode \'<&\'/ or print "not "; -print "ok 32\n"; +ok; diff --git a/t/io/print.t b/t/io/print.t index 180b1e88d7..0578ee6a29 100755 --- a/t/io/print.t +++ b/t/io/print.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: print.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:32 $ - -print "1..16\n"; +print "1..18\n"; $foo = 'STDOUT'; print $foo "ok 1\n"; @@ -30,3 +28,7 @@ print "ok","11"; @x = ("ok","12\nok","13\nok"); @y = ("15\nok","16"); print @x,"14\nok",@y; +{ + local $\ = "ok 17\n# null =>[\000]\nok 18\n"; + print ""; +} diff --git a/t/lib/charnames.t b/t/lib/charnames.t index 8d5c8db384..b03083e6d1 100644 --- a/t/lib/charnames.t +++ b/t/lib/charnames.t @@ -15,24 +15,28 @@ use charnames ':full'; print "not " unless "Here\N{EXCLAMATION MARK}?" eq 'Here!?'; print "ok 1\n"; -print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' +{ + no utf8; # UTEST can switch it on + + print "# \$res=$res \$\@='$@'\nnot " + if $res = eval <<'EOE' use charnames ":full"; "Here: \N{CYRILLIC SMALL LETTER BE}!"; 1 EOE - or $@ !~ /above 0xFF/; -print "ok 2\n"; -# print "# \$res=$res \$\@='$@'\n"; + or $@ !~ /above 0xFF/; + print "ok 2\n"; + # print "# \$res=$res \$\@='$@'\n"; -print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' + print "# \$res=$res \$\@='$@'\nnot " + if $res = eval <<'EOE' use charnames 'cyrillic'; "Here: \N{Be}!"; 1 EOE - or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/; -print "ok 3\n"; + or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/; + print "ok 3\n"; +} # If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt $encoded_be = "\320\261"; diff --git a/t/lib/filefind.t b/t/lib/filefind.t index 5d1492f040..f958b19cad 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -1,14 +1,105 @@ -#!./perl +####!./perl + + +my %Expect; +my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } -print "1..2\n"; +if ( $symlink_exists ) { print "1..59\n"; } +else { print "1..31\n"; } use File::Find; -# hope we will eventually find ourself find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); + + +my $case = 2; + +END { + unlink 'FA/FA_ord','FA/FSL','FA/FAA/FAA_ord', + 'FA/FAB/FAB_ord','FA/FAB/FABA/FABA_ord','FB/FB_ord','FB/FBA/FBA_ord'; + rmdir 'FA/FAA'; + rmdir 'FA/FAB/FABA'; + rmdir 'FA/FAB'; + rmdir 'FA'; + rmdir 'FB/FBA'; + rmdir 'FB'; +} + +sub Check($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n"; } +} + +sub CheckDie($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n $!\n"; exit 0; } +} + +sub touch { + CheckDie( open(my $T,'>',$_[0]) ); +} + +sub MkDir($$) { + CheckDie( mkdir($_[0],$_[1]) ); +} + +sub wanted { + print "# '$_' => 1\n"; + Check( $Expect{$_} ); + delete $Expect{$_}; + $File::Find::prune=1 if $_ eq 'FABA'; +} + +MkDir( 'FA',0770 ); +MkDir( 'FB',0770 ); +touch('FB/FB_ord'); +MkDir( 'FB/FBA',0770 ); +touch('FB/FBA/FBA_ord'); +CheckDie( symlink('../FB','FA/FSL') ) if $symlink_exists; +touch('FA/FA_ord'); + +MkDir( 'FA/FAA',0770 ); +touch('FA/FAA/FAA_ord'); +MkDir( 'FA/FAB',0770 ); +touch('FA/FAB/FAB_ord'); +MkDir( 'FA/FAB/FABA',0770 ); +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; +File::Find::find( {wanted => \&wanted, },'FA' ); +Check( scalar(keys %Expect) == 0 ); + +%Expect=('FA' => 1, 'FA/FSL' => 1, 'FA/FA_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); +delete $Expect{'FA/FSL'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, no_chdir => 1},'FA' ); + +Check( scalar(keys %Expect) == 0 ); + +if ( $symlink_exists ) { + %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); + + File::Find::find( {wanted => \&wanted, follow_fast => 1},'FA' ); + Check( scalar(keys %Expect) == 0 ); + %Expect=('FA' => 1, 'FA/FA_ord' => 1, 'FA/FSL' => 1, 'FA/FSL/FB_ord' => 1, + '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); + File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'FA' ); + Check( scalar(keys %Expect) == 0 ); +} + +print "# of cases: $case\n"; diff --git a/t/lib/glob-case.t b/t/lib/glob-case.t new file mode 100755 index 0000000000..2e65a0fc8b --- /dev/null +++ b/t/lib/glob-case.t @@ -0,0 +1,48 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + print "1..7\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob qw(:glob csh_glob); +$loaded = 1; +print "ok 1\n"; + +# Test the actual use of the case sensitivity tags, via csh_glob() +import File::Glob ':nocase'; +@a = csh_glob("lib/G*.t"); # At least glob-basic.t glob-case.t glob-global.t +print "not " unless @a >= 3; +print "ok 2\n"; + +# This may fail on systems which are not case-PRESERVING +import File::Glob ':case'; +@a = csh_glob("lib/G*.t"); # None should be uppercase +print "not " unless @a == 0; +print "ok 3\n"; + +# Test the explicit use of the GLOB_NOCASE flag +@a = File::Glob::glob("lib/G*.t", GLOB_NOCASE); +print "not " unless @a >= 3; +print "ok 4\n"; + +# Test Win32 backslash nastiness... +if ($^O ne 'MSWin32') { + print "ok 5\nok 6\nok 7\n"; +} +else { + @a = File::Glob::glob("lib\\g*.t"); + print "not " unless @a >= 3; + print "ok 5\n"; + mkdir "[]", 0; + @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); + rmdir "[]"; + print "# returned @a\nnot " unless @a == 1; + print "ok 6\n"; + @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + print "not " if @a == 0; + print "ok 7\n"; +} diff --git a/t/lib/glob-global.t b/t/lib/glob-global.t index 7da741ee16..44d7e8b5c3 100755 --- a/t/lib/glob-global.t +++ b/t/lib/glob-global.t @@ -23,7 +23,7 @@ EOMessage } } -use File::Glob 'globally'; +use File::Glob ':globally'; $loaded = 1; print "ok 1\n"; @@ -81,7 +81,7 @@ print "ok 8\n"; # how about in a different package, like? package Foo; -use File::Glob 'globally'; +use File::Glob ':globally'; @s = (); while (glob '*/*.t') { #print "# $_\n"; diff --git a/t/lib/io_unix.t b/t/lib/io_unix.t index 7338861fb4..0e559e0d90 100644 --- a/t/lib/io_unix.t +++ b/t/lib/io_unix.t @@ -5,6 +5,10 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib' if -d '../lib'; } + # ``use IO::Socket'' executes too early below in the os2 block + if ($^O eq 'dos') { + print "1..0 # Skip: no fork\n"; + } } use Config; diff --git a/t/lib/ipc_sysv.t b/t/lib/ipc_sysv.t index 00a157ba54..9777292f37 100755 --- a/t/lib/ipc_sysv.t +++ b/t/lib/ipc_sysv.t @@ -77,8 +77,34 @@ if ($Config{'d_msgget'} eq 'define' && my $msgtype = 1; my $msgtext = "hello"; - msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not "; + my $test2bad; + my $test5bad; + my $test6bad; + + unless (msgsnd($msg,pack("L a*",$msgtype,$msgtext),IPC_NOWAIT)) { + print "not "; + $test2bad = 1; + } print "ok 2\n"; + if ($test2bad) { + print <<EOM; +# +# The failure of the subtest #2 may indicate that the message queue +# resource limits either of the system or of the testing account +# have been reached. Error message "Operating would block" is +# usually indicative of this situation. The error message was now: +# "$!" +# +# You can check the message queues with the 'ipcs' command and +# you can remove unneeded queues with the 'ipcrm -q id' command. +# You may also consider configuring your system or account +# to have more message queue resources. +# +# Because of the subtest #2 failing also the substests #5 and #6 will +# very probably also fail. +# +EOM + } my $data; msgctl($msg,IPC_STAT,$data) or print "not "; @@ -88,13 +114,33 @@ if ($Config{'d_msgget'} eq 'define' && print "ok 4\n"; my $msgbuf; - msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not "; + unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) { + print "not "; + $test5bad = 1; + } print "ok 5\n"; + if ($test5bad && $test2bad) { + print <<EOM; +# +# This failure was to be expected because the subtest #2 failed. +# +EOM + } my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf); - print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext); + unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext) { + print "not "; + $test6bad = 1; + } print "ok 6\n"; + if ($test6bad && $test2bad) { + print <<EOM; +# +# This failure was to be expected because the subtest #2 failed. +# +EOM + } } else { for (1..6) { print "ok $_\n"; # fake it diff --git a/t/lib/syslfs.t b/t/lib/syslfs.t index 43e66feb59..942bb4dad6 100644 --- a/t/lib/syslfs.t +++ b/t/lib/syslfs.t @@ -3,12 +3,6 @@ # If you modify/add tests here, remember to update also t/op/lfs.t. BEGIN { - # Don't bother if there are no quads. - eval { my $q = pack "q", 0 }; - if ($@) { - print "1..0\n# no 64-bit types\n"; - exit(0); - } chdir 't' if -d 't'; unshift @INC, '../lib'; require Config; import Config; @@ -43,20 +37,22 @@ sub explain { EOM } +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\n"; + print "1..0\n# 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\n"; + print "1..0\n# large files known to work but unable to test them here ($^O)\n"; bye(); } -# Then try to deduce whether we have sparse files. +# Then try heuristically to deduce whether we have sparse files. # We'll start off by creating a one megabyte file which has # only three "true" bytes. If we have sparseness, we should @@ -85,24 +81,31 @@ unless (@s == 13 && bye(); } +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. $ENV{LC_ALL} = "C"; sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or - do { warn "sysopen failed: $!\n"; bye }; -sysseek(BIG, 5_000_000_000, SEEK_SET); + 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"; + explain(); + bye(); +} # The syswrite will fail if there are are filesize limitations (process or fs). -my $syswrite = syswrite(BIG, "big") == 3; -my $close = close BIG if $syswrite; +my $syswrite = syswrite(BIG, "big"); +print "# syswrite failed: $! (syswrite returned ", + defined $syswrite ? $syswrite : 'undef', ")\n" + unless defined $syswrite && $syswrite == 3; +my $close = close BIG; +print "# close failed: $!\n" unless $close; unless($syswrite && $close) { - unless ($syswrite) { - print "# syswrite failed: $!\n" - } else { - print "# close failed: $!\n" - } if ($! =~/too large/i) { print "1..0\n# writing past 2GB failed: process limits?\n"; } elsif ($! =~ /quota/i) { diff --git a/t/op/array.t b/t/op/array.t index 3409556396..1108f494f8 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..65\n"; +print "1..66\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -211,3 +211,8 @@ my $t = 63; sub reify { $_[1] = ++$t; print "@_\n"; } reify('ok'); reify('ok'); + +# qw() is no more a runtime split, it's compiletime. +print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; +print "ok 66\n"; + diff --git a/t/op/fork.t b/t/op/fork.t index 20c87472b2..be9565365e 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -1,26 +1,315 @@ #!./perl -# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ +# tests for both real and emulated fork() BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; require Config; import Config; - unless ($Config{'d_fork'}) { + unless ($Config{'d_fork'} || $Config{ccflags} =~ /-DUSE_ITHREADS\b/) { print "1..0 # Skip: no fork\n"; exit 0; } + $ENV{PERL5LIB} = "../lib"; } -$| = 1; -print "1..2\n"; +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "forktmp000"; +1 while -f ++$tmpfile; +END { unlink $tmpfile if $tmpfile; } + +$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); +for (@prgs){ + my $switch; + if (s/^\s*(-\w.*)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + $expected =~ s/\n+$//; + # results can be in any order, so sort 'em + my @expected = sort split /\n/, $expected; + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + print TEST $prog, "\n"; + close TEST or die "Cannot close $tmpfile: $!"; + my $results; + if ($^O eq 'MSWin32') { + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; + } + else { + $results = `./perl $switch $tmpfile 2>&1`; + } + $status = $?; + $results =~ s/\n+$//; + $results =~ s/at\s+forktmp\d+\s+line/at - line/g; + $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + my @results = sort split /\n/, $results; + if ( "@results" ne "@expected" ) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +__END__ +$| = 1; if ($cid = fork) { - sleep 2; - if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} + sleep 1; + if ($result = (kill 9, $cid)) { + print "ok 2\n"; + } + else { + print "not ok 2 $result\n"; + } + sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug } else { - $| = 1; print "ok 1\n"; sleep 10; } +EXPECT +ok 1 +ok 2 +######## +$| = 1; +sub forkit { + print "iteration $i start\n"; + my $x = fork; + if (defined $x) { + if ($x) { + print "iteration $i parent\n"; + } + else { + print "iteration $i child\n"; + } + } + else { + print "pid $$ failed to fork\n"; + } +} +while ($i++ < 3) { do { forkit(); }; } +EXPECT +iteration 1 start +iteration 1 parent +iteration 1 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +######## +$| = 1; +fork() + ? (print("parent\n"),sleep(1)) + : (print("child\n"),exit) ; +EXPECT +parent +child +######## +$| = 1; +fork() + ? (print("parent\n"),exit) + : (print("child\n"),sleep(1)) ; +EXPECT +parent +child +######## +$| = 1; +@a = (1..3); +for (@a) { + if (fork) { + print "parent $_\n"; + $_ = "[$_]"; + } + else { + print "child $_\n"; + $_ = "-$_-"; + } +} +print "@a\n"; +EXPECT +parent 1 +child 1 +parent 2 +child 2 +parent 2 +child 2 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +[1] [2] [3] +-1- [2] [3] +[1] -2- [3] +[1] [2] -3- +-1- -2- [3] +-1- [2] -3- +[1] -2- -3- +-1- -2- -3- +######## +use Config; +$| = 1; +$\ = "\n"; +fork() + ? print($Config{osname} eq $^O) + : print($Config{osname} eq $^O) ; +EXPECT +1 +1 +######## +$| = 1; +$\ = "\n"; +fork() + ? do { require Config; print($Config::Config{osname} eq $^O); } + : do { require Config; print($Config::Config{osname} eq $^O); } +EXPECT +1 +1 +######## +$| = 1; +use Cwd; +$\ = "\n"; +my $dir; +if (fork) { + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; + chdir ".."; + rmdir $dir; +} +else { + sleep 2; + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; + chdir ".."; + rmdir $dir; +} +EXPECT +ok 1 parent +ok 1 child +######## +$| = 1; +$\ = "\n"; +my $getenv; +if ($^O eq 'MSWin32') { + $getenv = qq[$^X -e "print \$ENV{TST}"]; +} +else { + $getenv = qq[$^X -e 'print \$ENV{TST}']; +} +if (fork) { + sleep 1; + $ENV{TST} = 'foo'; + print "parent: " . `$getenv`; +} +else { + $ENV{TST} = 'bar'; + print "child: " . `$getenv`; + sleep 1; +} +EXPECT +parent: foo +child: bar +######## +$| = 1; +$\ = "\n"; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exit(42); +} +EXPECT +parent got 10752 +######## +$| = 1; +$\ = "\n"; +my $echo = 'echo'; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exec("$echo foo"); +} +EXPECT +foo +parent got 0 +######## +if (fork) { + die "parent died"; +} +else { + die "child died"; +} +EXPECT +parent died at - line 2. +child died at - line 5. +######## +if ($pid = fork) { + eval { die "parent died" }; + print $@; +} +else { + eval { die "child died" }; + print $@; +} +EXPECT +parent died at - line 2. +child died at - line 6. +######## +if (eval q{$pid = fork}) { + eval q{ die "parent died" }; + print $@; +} +else { + eval q{ die "child died" }; + print $@; +} +EXPECT +parent died at (eval 2) line 1. +child died at (eval 2) line 1. +######## +BEGIN { + $| = 1; + fork and exit; + print "inner\n"; +} +# XXX In emulated fork(), the child will not execute anything after +# the BEGIN block, due to difficulties in recreating the parse stacks +# and restarting yyparse() midstream in the child. This can potentially +# be overcome by treating what's after the BEGIN{} as a brand new parse. +#print "outer\n" +EXPECT +inner diff --git a/t/op/lfs.t b/t/op/lfs.t index 87060e74c6..0d6d027743 100644 --- a/t/op/lfs.t +++ b/t/op/lfs.t @@ -3,12 +3,6 @@ # If you modify/add tests here, remember to update also t/lib/syslfs.t. BEGIN { - # Don't bother if there are no quads. - eval { my $q = pack "q", 0 }; - if ($@) { - print "1..0\n# no 64-bit types\n"; - exit(0); - } chdir 't' if -d 't'; unshift @INC, '../lib'; # Don't bother if there are no quad offsets. @@ -42,20 +36,22 @@ sub explain { EOM } +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\n"; + print "1..0\n# 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\n"; + print "1..0\n# large files known to work but unable to test them here ($^O)\n"; bye(); } -# Then try to deduce whether we have sparse files. +# Then try to heuristically deduce whether we have sparse files. # Let's not depend on Fcntl or any other extension. @@ -88,6 +84,8 @@ unless (@s == 13 && bye(); } +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. @@ -95,18 +93,19 @@ $ENV{LC_ALL} = "C"; open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; binmode BIG; -seek(BIG, 5_000_000_000, $SEEK_SET); +unless (seek(BIG, 5_000_000_000, $SEEK_SET)) { + print "1..0\n# seeking past 2GB failed: $!\n"; + explain(); + bye(); +} # Either the print or (more likely, thanks to buffering) the close will # fail if there are are filesize limitations (process or fs). my $print = print BIG "big"; -my $close = close BIG if $print; +print "# print failed: $!\n" unless $print; +my $close = close BIG; +print "# close failed: $!\n" unless $close; unless ($print && $close) { - unless ($print) { - print "# print failed: $!\n" - } else { - print "# close failed: $!\n" - } if ($! =~/too large/i) { print "1..0\n# writing past 2GB failed: process limits?\n"; } elsif ($! =~ /quota/i) { diff --git a/t/op/misc.t b/t/op/misc.t index adfcd174fc..9f8c7dedab 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -353,16 +353,18 @@ Unmatched right curly bracket at (re_eval 1) line 1, at end of line syntax error at (re_eval 1) line 1, near ""{"}" Compilation failed in regexp at - line 1. ######## -BEGIN { @ARGV = qw(a b c) } +BEGIN { @ARGV = qw(a b c d e) } BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } END { print "end <",shift,">\nargv <@ARGV>\n" } INIT { print "init <",shift,">\n" } +STOP { print "stop <",shift,">\n" } EXPECT -argv <a b c> +argv <a b c d e> begin <a> -init <b> -end <c> -argv <> +stop <b> +init <c> +end <d> +argv <e> ######## -l # fdopen from a system descriptor to a system descriptor used to close @@ -504,4 +506,4 @@ else { if ($x == 0) { print "" } else { print $x } } EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in numeric eq (==) at - line 4. diff --git a/t/op/pack.t b/t/op/pack.t index 11ada3905d..2d34311f1f 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -381,7 +381,9 @@ print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "not ok $test\n"; $test++; eval { ($x) = unpack 'a/a*/b*', '212ab' }; -print $@ eq '' && $x eq '100001100100' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; +my $expected_x = '100001100100'; +if ($Config{ebcdic} eq 'define') { $expected_x = '100000010100'; } +print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; $test++; # 153..156: / with # diff --git a/t/op/pat.t b/t/op/pat.t index f36394edc2..5c564aa719 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..193\n"; +print "1..194\n"; BEGIN { chdir 't' if -d 't'; @@ -893,3 +893,8 @@ pos($text)=0; $text =~ /\GXb*X/g and print 'not '; print "ok $test\n"; $test++; + +$text = "xA\n" x 500; +$text =~ /^\s*A/m and print 'not '; +print "ok $test\n"; +$test++; diff --git a/t/op/re_tests b/t/op/re_tests index d72a0f73b2..357b705158 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -742,3 +742,9 @@ tt+$ xxxtt y - - ([[:digit:]-z]+) =0-z= y $1 0-z ([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z \GX.*X aaaXbX n - - +(\d+\.\d+) 3.1415926 y $1 3.1415926 +(\ba.{0,10}br) have a web browser y $1 a web br +'\.c(pp|xx|c)?$'i Changes n - - +'\.c(pp|xx|c)?$'i IO.c y - - +'(\.c(pp|xx|c)?$)'i IO.c y $1 .c +^([a-z]:) C:/ n - - diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 1dc2a234b2..1d923cf1b5 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -3,7 +3,7 @@ ## ## Many of these tests are originally from Michael Schroeder ## <Michael.Schroeder@informatik.uni-erlangen.de> -## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> +## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> ## chdir 't' if -d 't'; @@ -57,7 +57,7 @@ __END__ @a = sort { last ; } @a; } EXPECT -Can't "last" outside a block at - line 3. +Can't "last" outside a loop block at - line 3. ######## package TEST; @@ -174,7 +174,7 @@ exit; bar: print "bar reached\n"; EXPECT -Can't "goto" outside a block at - line 2. +Can't "goto" out of a pseudo block at - line 2. ######## sub sortfn { (split(/./, 'x'x10000))[0]; @@ -227,7 +227,7 @@ tie $bar, TEST; } print "OK\n"; EXPECT -Can't "next" outside a block at - line 8. +Can't "next" outside a loop block at - line 8. ######## package TEST; @@ -285,7 +285,7 @@ package main; tie $bar, TEST; } EXPECT -Can't "next" outside a block at - line 4. +Can't "next" outside a loop block at - line 4. ######## @a = (1, 2, 3); foo: diff --git a/t/op/sort.t b/t/op/sort.t index 9abc4105d2..6e3d2ca8e0 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -4,12 +4,13 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; } -print "1..38\n"; +print "1..49\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -40,96 +41,107 @@ $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; print "# 2: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); +$x = join('', sort( backwards_stacked @harry)); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 3\n" : "not ok 3\n"); + $x = join('', sort @george, 'to', @harry); $expected = $upperfirst ? 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; -print "# 3: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ?"ok 3\n":"not ok 3\n"); +print "# 4: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 4\n":"not ok 4\n"); @a = (); @b = reverse @a; -print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); +print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n"); @a = (1); @b = reverse @a; -print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); +print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n"); @a = (1,2); @b = reverse @a; -print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); +print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); @a = (1,2,3); @b = reverse @a; -print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); +print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); @a = (1,2,3,4); @b = reverse @a; -print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); +print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n"); @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; -print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); +print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n"); $sub = 'backwards'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 10: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); +print "# 11: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 11\n" : "not ok 11\n"); + +$sub = 'backwards_stacked'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 12: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 12\n" : "not ok 12\n"); # literals, combinations @b = sort (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); print "# x = '@b'\n"; @b = sort grep { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; @b = sort map { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n"); print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); print "# x = '@b'\n"; $^W = 0; # redefining sort sub inside the sort sub should fail sub twoface { *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); +print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); # redefining sort subs outside the sort should not fail eval { *twoface = sub { &backwards } }; -print $@ ? "not ok 16\n" : "ok 16\n"; +print $@ ? "not ok 18\n" : "ok 18\n"; eval { @b = sort twoface 4,1,3,2 }; -print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); +print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); *twoface = sub { *twoface = *backwards; $a <=> $b }; eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); +print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); *twoface = sub { eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); $a <=> $b; }; eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 19\n"; +print $@ ? "$@" : "not ok 21\n"; eval <<'CODE'; my @result = sort main'backwards 'one', 'two'; CODE -print $@ ? "not ok 20\n# $@" : "ok 20\n"; +print $@ ? "not ok 22\n# $@" : "ok 22\n"; eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub my @result = sort 'one', 'two'; CODE -print $@ ? "not ok 21\n# $@" : "ok 21\n"; +print $@ ? "not ok 23\n# $@" : "ok 23\n"; { my $sortsub = \&backwards; @@ -137,13 +149,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $sortglobr = \*backwards; my $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); +} + +{ + my $sortsub = \&backwards_stacked; + my $sortglob = *backwards_stacked; + my $sortglobr = \*backwards_stacked; + my $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n"); } { @@ -152,13 +179,28 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; local $sortglobr = \*backwards; local $sortname = 'backwards'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n"); +} + +{ + local $sortsub = \&backwards_stacked; + local $sortglob = *backwards_stacked; + local $sortglobr = \*backwards_stacked; + local $sortname = 'backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n"); } ## exercise sort builtins... ($a <=> $b already tested) @@ -167,42 +209,46 @@ print $@ ? "not ok 21\n# $@" : "ok 21\n"; my $dummy; # force blockness return $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 30\n" : "not ok 30\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; -print ($x eq $expected ? "ok 31\n" : "not ok 31\n"); +print ($x eq $expected ? "ok 41\n" : "not ok 41\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print ($x eq $expected ? "ok 32\n" : "not ok 32\n"); +print ($x eq $expected ? "ok 42\n" : "not ok 42\n"); print "# x = '$x'; expected = '$expected'\n"; { use integer; @b = sort { $a <=> $b } @a; - print ("@b" eq '5 19 90 255 1996' ? "ok 33\n" : "not ok 33\n"); + print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n"); print "# x = '@b'\n"; @b = sort { $b <=> $a } @a; - print ("@b" eq '1996 255 90 19 5' ? "ok 34\n" : "not ok 34\n"); + print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n"); print "# x = '@b'\n"; $x = join('', sort { $a cmp $b } @harry); $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; - print ($x eq $expected ? "ok 35\n" : "not ok 35\n"); + print ($x eq $expected ? "ok 45\n" : "not ok 45\n"); print "# x = '$x'; expected = '$expected'\n"; $x = join('', sort { $b cmp $a } @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; - print ($x eq $expected ? "ok 36\n" : "not ok 36\n"); + print ($x eq $expected ? "ok 46\n" : "not ok 46\n"); print "# x = '$x'; expected = '$expected'\n"; } # test that an optimized-away comparison block doesn't take any other # arguments away with it $x = join('', sort { $a <=> $b } 3, 1, 2); -print $x eq "123" ? "ok 37\n" : "not ok 37\n"; +print $x eq "123" ? "ok 47\n" : "not ok 47\n"; # test sorting in non-main package package Foo; @a = ( 5, 19, 1996, 255, 90 ); @b = sort { $b <=> $a } @a; -print ("@b" eq '1996 255 90 19 5' ? "ok 38\n" : "not ok 38\n"); +print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n"); +print "# x = '@b'\n"; + +@b = sort main::backwards_stacked @a; +print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); print "# x = '@b'\n"; diff --git a/t/op/subst.t b/t/op/subst.t index 2d15df4dc1..9757f4c595 100755 --- a/t/op/subst.t +++ b/t/op/subst.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..83\n"; +print "1..84\n"; $x = 'foo'; $_ = "x"; @@ -375,4 +375,7 @@ $x = $x = 'interp'; eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; +$_ = "C:/"; +s/^([a-z]:)/\u$1/ and print "not "; +print "ok 84\n"; diff --git a/t/pod/poderrs.t b/t/pod/poderrs.t index 9cbbeeeb91..9f7f6bd341 100755 --- a/t/pod/poderrs.t +++ b/t/pod/poderrs.t @@ -36,4 +36,81 @@ Camps is very, entertaining. And they say we'll have some fun if it stops raining! +=head1 Additional tests + +=head2 item without over + +=item oops + +=head2 back without over + +=back + +=head2 over without back + +=over 4 + +=item oops + +=head2 end without begin + +=end + +=head2 begin and begin + +=begin html + +=begin text + +=end + +=end + +=head2 Nested sequences of the same type + +C<code I<italic C<code again!>>> + +=head2 Garbled entities + +E<alea iacta est> +E<C<auml>> +E<abcI<bla>> + +=head2 Unresolved internal links + +L</"begin or begin"> +L<"end with begin"> +L</OoPs> + +=head2 Garbled (almost) links + +L<s s / s s / ss> +L<".".":"> +L<"h"/"hh"> +L<a|b|c> + +=head2 Warnings + +L<passwd(5)> +L< some text|page/"section" > + +=over 4 + +=item bla + +=back 200 + +=begin html + +What? + +=end xml + +=over 4 + +=back + +see these unescaped < and > in the text? + =cut + diff --git a/t/pod/poderrs.xr b/t/pod/poderrs.xr index 82d402d8b2..70408cd2f4 100644 --- a/t/pod/poderrs.xr +++ b/t/pod/poderrs.xr @@ -3,9 +3,33 @@ *** ERROR: Unknown interior-sequence "D" at line 22 in file pod/poderrs.t *** ERROR: Unknown interior-sequence "Q" at line 25 in file pod/poderrs.t *** ERROR: Unknown interior-sequence "A" at line 26 in file pod/poderrs.t -*** ERROR: Unknown interior-sequence "V" at line 27 in file pod/poderrs.t *** ERROR: Unknown interior-sequence "Y" at line 27 in file pod/poderrs.t +*** ERROR: Unknown interior-sequence "V" at line 27 in file pod/poderrs.t ** Unterminated B<...> at pod/poderrs.t line 31 ** Unterminated I<...> at pod/poderrs.t line 30 ** Unterminated C<...> at pod/poderrs.t line 33 -pod/poderrs.t has 10 pod syntax errors. +*** ERROR: =item without previous =over at line 43 in file pod/poderrs.t +*** ERROR: =back without previous =over at line 47 in file pod/poderrs.t +*** ERROR: unclosed =over (line 51) at head2 at line 55 in file pod/poderrs.t +*** WARNING: =end without =begin at line 57 in file pod/poderrs.t +*** ERROR: Nested =begin's (first at line 61:html) at line 63 in file pod/poderrs.t +*** WARNING: =end without =begin at line 67 in file pod/poderrs.t +*** ERROR: nested commands C<...C<...>...> at line 71 in file pod/poderrs.t +*** ERROR: garbled entity E<alea iacta est> at line 75 in file pod/poderrs.t +*** ERROR: garbled entity E<C<auml>> at line 76 in file pod/poderrs.t +*** ERROR: garbled entity E<abcI<bla>> at line 77 in file pod/poderrs.t +*** ERROR: malformed link L<>: garbled entry (spurious characters `s s / s s / ss') at line 87 in file pod/poderrs.t +*** ERROR: malformed link L<>: garbled entry (spurious characters `".".":"') at line 88 in file pod/poderrs.t +*** ERROR: malformed link L<>: garbled entry (spurious characters `"h"/"hh"') at line 89 in file pod/poderrs.t +*** WARNING: brackets in `passwd(5)' at line 94 in file pod/poderrs.t +*** WARNING: ignoring leading whitespace in link at line 95 in file pod/poderrs.t +*** WARNING: ignoring trailing whitespace in link at line 95 in file pod/poderrs.t +*** WARNING: Spurious character(s) after =back at line 101 in file pod/poderrs.t +*** WARNING: Spurious character(s) after =end at line 107 in file pod/poderrs.t +*** WARNING: No items in =over (at line 109) / =back list at line 111 in file pod/poderrs.t +*** WARNING: 2 unescaped <> at line 113 in file pod/poderrs.t +*** ERROR: unresolved internal link `begin or begin' at line 81 in file pod/poderrs.t +*** ERROR: unresolved internal link `end with begin' at line 82 in file pod/poderrs.t +*** ERROR: unresolved internal link `OoPs' at line 83 in file pod/poderrs.t +*** ERROR: unresolved internal link `b|c' at line 90 in file pod/poderrs.t +pod/poderrs.t has 25 pod syntax errors. diff --git a/t/pod/testpchk.pl b/t/pod/testpchk.pl index 07236e69e7..640226bde7 100644 --- a/t/pod/testpchk.pl +++ b/t/pod/testpchk.pl @@ -30,20 +30,7 @@ sub stripname( $ ) { } sub msgcmp( $ $ ) { - ## filter out platform-dependent aspects of error messages my ($line1, $line2) = @_; - for ($line1, $line2) { - if ( /^#*\s*(\S.*?)\s+(?:has \d+\s*)?pod syntax (?:error|OK)/ ) { - my $fname = $1; - s/^#*\s*// if ($^O eq 'MacOS'); - s/^\s*\Q$fname\E/stripname($fname)/e; - } - elsif ( /^#*\s*\*+\s*(?:ERROR|Unterminated)/ ) { - s/^#*\s*// if ($^O eq 'MacOS'); - s/of file\s+(\S.*?)\s*$/"of file ".stripname($1)/e; - s/at\s+(\S.*?)\s+line/"at ".stripname($1)." line"/e; - } - } return $line1 ne $line2; } diff --git a/t/pragma/locale.t b/t/pragma/locale.t index c453c47bd1..76426787ca 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -286,6 +286,11 @@ Turkish:tr:tr:9 turkish8 Yiddish:::1 15 EOF +if ($^O eq 'os390') { + $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; + $locales =~ s/Thai:th:th:11 tis620\n//; +} + sub in_utf8 () { $^H & 0x08 } if (in_utf8) { @@ -323,6 +328,9 @@ sub decode_encodings { push @enc, $_; } } + if ($^O eq 'os390') { + push @enc, qw(IBM-037 IBM-819 IBM-1047); + } return @enc; } diff --git a/t/pragma/warn/1global b/t/pragma/warn/1global index 836b7f513f..0af80221b2 100644 --- a/t/pragma/warn/1global +++ b/t/pragma/warn/1global @@ -43,7 +43,7 @@ EXPECT $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## # warnings enabled at compile time, disabled at run time @@ -59,7 +59,7 @@ BEGIN { $^W = 0 } $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## -w --FILE-- abcd @@ -68,7 +68,7 @@ my $b ; chop $b ; --FILE-- require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -78,7 +78,7 @@ my $b ; chop $b ; #! perl -w require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -88,7 +88,7 @@ my $b ; chop $b ; $^W =1 ; require "./abcd"; EXPECT -Use of uninitialized value at ./abcd line 1. +Use of uninitialized value in scalar chop at ./abcd line 1. ######## --FILE-- abcd @@ -110,28 +110,28 @@ $^W =0 ; require "./abcd"; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## $^W = 1; eval 'my $b ; chop $b ;' ; print $@ ; EXPECT -Use of uninitialized value at (eval 1) line 1. +Use of uninitialized value in scalar chop at (eval 1) line 1. ######## eval '$^W = 1;' ; print $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## eval {$^W = 1;} ; print $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar chop at - line 4. ######## { @@ -149,12 +149,12 @@ my $a ; chop $a ; } my $c ; chop $c ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## -w -e undef EXPECT -Use of uninitialized value at - line 2. +Use of uninitialized value in -e at - line 2. ######## $^W = 1 + 2 ; @@ -186,4 +186,4 @@ sub fred { my $b ; chop $b ;} fred() ; } EXPECT -Use of uninitialized value at - line 2. +Use of uninitialized value in scalar chop at - line 2. diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use index 4ec4da0a77..384b3b361e 100644 --- a/t/pragma/warn/2use +++ b/t/pragma/warn/2use @@ -42,7 +42,7 @@ use warnings 'uninitialized' ; } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -53,7 +53,7 @@ no warnings ; } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check runtime scope of pragma @@ -64,7 +64,7 @@ no warnings ; } &$a ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## use warnings 'deprecated' ; @@ -103,7 +103,7 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm @@ -116,7 +116,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval @@ -137,7 +137,7 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check scope of pragma with eval @@ -147,8 +147,8 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -159,7 +159,7 @@ eval { }; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -223,7 +223,7 @@ eval q[ ]; print STDERR $@; my $b ; chop $b ; EXPECT -Use of uninitialized value at (eval 1) line 3. +Use of uninitialized value in scalar chop at (eval 1) line 3. ######## # Check scope of pragma with eval @@ -233,8 +233,8 @@ eval ' '; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at (eval 1) line 2. -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -245,7 +245,7 @@ eval ' '; print STDERR $@ ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -303,6 +303,6 @@ no warnings 'deprecated' ; 1 if $a EQ $b ; EXPECT Use of EQ is deprecated at - line 6. -Use of uninitialized value at - line 9. -Use of uninitialized value at - line 11. -Use of uninitialized value at - line 11. +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 592724ad73..132b99b80f 100644 --- a/t/pragma/warn/3both +++ b/t/pragma/warn/3both @@ -13,7 +13,7 @@ sub fred { } EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -27,7 +27,7 @@ sub fred { } EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -64,7 +64,7 @@ $^W = 1 ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -73,7 +73,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -107,7 +107,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 5. +Use of uninitialized value in scalar chop at - line 5. ######## # Check interaction of $^W and use warnings @@ -119,7 +119,7 @@ sub fred { BEGIN { $^W = 0 } fred() ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -141,7 +141,7 @@ BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -150,7 +150,7 @@ use warnings ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check interaction of $^W and use warnings @@ -181,7 +181,7 @@ BEGIN { $^W = 1 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in scalar chop at - line 10. ######## # Check interaction of $^W and use warnings @@ -194,4 +194,4 @@ BEGIN { $^W = 0 } my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 7. +Use of uninitialized value in scalar chop at - line 7. diff --git a/t/pragma/warn/4lint b/t/pragma/warn/4lint index 6a08409bb2..b7c64c31ac 100644 --- a/t/pragma/warn/4lint +++ b/t/pragma/warn/4lint @@ -67,7 +67,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc @@ -81,7 +81,7 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc.pm @@ -95,7 +95,7 @@ use abc; my $a ; chop $a ; EXPECT Use of EQ is deprecated at abc.pm line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## -W --FILE-- abc @@ -109,4 +109,4 @@ require "./abc"; my $a ; chop $a ; EXPECT Use of EQ is deprecated at ./abc line 3. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. diff --git a/t/pragma/warn/7fatal b/t/pragma/warn/7fatal index fe94511f3e..943bb06fb3 100644 --- a/t/pragma/warn/7fatal +++ b/t/pragma/warn/7fatal @@ -23,7 +23,7 @@ use warnings FATAL => 'uninitialized' ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -35,7 +35,7 @@ no warnings ; &$a ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## --FILE-- abc @@ -69,7 +69,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at ./abc line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm @@ -83,7 +83,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Use of EQ is deprecated at abc.pm line 2. -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval @@ -95,7 +95,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at - line 6. +-- Use of uninitialized value in scalar chop at - line 6. The End. ######## @@ -107,8 +107,8 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at - line 5. -Use of uninitialized value at - line 7. +-- Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -120,7 +120,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -178,7 +178,7 @@ eval q[ my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at (eval 1) line 3. +-- Use of uninitialized value in scalar chop at (eval 1) line 3. The End. ######## @@ -190,8 +190,8 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value at (eval 1) line 2. -Use of uninitialized value at - line 7. +-- Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -203,7 +203,7 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index 5101bdef80..4706aebfdc 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -123,7 +123,7 @@ print $a ; no warnings 'uninitialized' ; print $b ; EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in print at - line 3. ######## # doio.c [Perl_my_stat Perl_my_lstat] use warnings 'io' ; diff --git a/t/pragma/warn/pp b/t/pragma/warn/pp index 48b5ec86b5..ea85912475 100644 --- a/t/pragma/warn/pp +++ b/t/pragma/warn/pp @@ -85,7 +85,7 @@ my $b = $$a; no warnings 'uninitialized' ; my $c = $$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in scalar dereference at - line 4. ######## # pp.c use warnings 'unsafe' ; diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl index 70e6d60e8d..f61da1a8e1 100644 --- a/t/pragma/warn/pp_ctl +++ b/t/pragma/warn/pp_ctl @@ -126,7 +126,7 @@ no warnings 'unsafe' ; @b = sort { last } @a ; EXPECT Exiting pseudo-block via last at - line 4. -Can't "last" outside a block at - line 4. +Can't "last" outside a loop block at - line 4. ######## # pp_ctl.c use warnings 'unsafe' ; diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 9a4b0a0708..379918b6b8 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -95,7 +95,7 @@ my @b = @$a; no warnings 'uninitialized' ; my @c = @$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in array dereference at - line 4. ######## # pp_hot.c [pp_rv2hv] use warnings 'uninitialized' ; @@ -104,7 +104,7 @@ my %b = %$a; no warnings 'uninitialized' ; my %c = %$a; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in hash dereference at - line 4. ######## # pp_hot.c [pp_aassign] use warnings 'unsafe' ; diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index 92b8208a65..1bdc4a9382 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -68,6 +68,7 @@ no warnings 'unsafe' ; /[[.foo.]]/; /[[=bar=]]/; /[:zog:]/; +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } /[[:zog:]]/; EXPECT Character class syntax [: :] belongs inside character classes at - line 4. @@ -78,7 +79,7 @@ Character class syntax [= =] is reserved for future extensions at - line 6. Character class syntax [. .] is reserved for future extensions at - line 8. Character class syntax [= =] is reserved for future extensions at - line 9. Character class syntax [: :] belongs inside character classes at - line 10. -Character class [:zog:] unknown at - line 19. +Character class [:zog:] unknown at - line 20. ######## # regcomp.c [S_regclass] $_ = ""; diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index c02ff01b82..d9de3b622f 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -58,7 +58,7 @@ $x = 1 + $a[0] ; # a no warnings 'uninitialized' ; $x = 1 + $b[0] ; # a EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in integer addition (+) at - line 4. ######## # sv.c (sv_2iv) package fred ; @@ -73,7 +73,7 @@ $A *= 2 ; no warnings 'uninitialized' ; $A *= 2 ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in integer multiplication (*) at - line 10. ######## # sv.c use integer ; @@ -82,7 +82,7 @@ my $x *= 2 ; #b no warnings 'uninitialized' ; my $y *= 2 ; #b EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in integer multiplication (*) at - line 4. ######## # sv.c (sv_2uv) package fred ; @@ -98,7 +98,7 @@ no warnings 'uninitialized' ; $B = 0 ; $B |= $A ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in bitwise or (|) at - line 10. ######## # sv.c use warnings 'uninitialized' ; @@ -108,7 +108,7 @@ no warnings 'uninitialized' ; my $Y = 1 ; $x = 1 | $b[$Y] ; EXPECT -Use of uninitialized value at - line 4. +Use of uninitialized value in bitwise or (|) at - line 4. ######## # sv.c use warnings 'uninitialized' ; @@ -116,7 +116,7 @@ my $x *= 1 ; # d no warnings 'uninitialized' ; my $y *= 1 ; # d EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in multiplication (*) at - line 3. ######## # sv.c use warnings 'uninitialized' ; @@ -124,7 +124,7 @@ $x = 1 + $a[0] ; # e no warnings 'uninitialized' ; $x = 1 + $b[0] ; # e EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in addition (+) at - line 3. ######## # sv.c (sv_2nv) package fred ; @@ -138,7 +138,7 @@ $A *= 2 ; no warnings 'uninitialized' ; $A *= 2 ; EXPECT -Use of uninitialized value at - line 9. +Use of uninitialized value in multiplication (*) at - line 9. ######## # sv.c use warnings 'uninitialized' ; @@ -146,7 +146,7 @@ $x = $y + 1 ; # f no warnings 'uninitialized' ; $x = $z + 1 ; # f EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in addition (+) at - line 3. ######## # sv.c use warnings 'uninitialized' ; @@ -162,7 +162,7 @@ $x = chop $y ; # h no warnings 'uninitialized' ; $x = chop $z ; # h EXPECT -Use of uninitialized value at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # sv.c (sv_2pv) package fred ; @@ -178,7 +178,7 @@ no warnings 'uninitialized' ; $C = "" ; $C .= $A ; EXPECT -Use of uninitialized value at - line 10. +Use of uninitialized value in concatenation (.) at - line 10. ######## # sv.c use warnings 'numeric' ; |