diff options
Diffstat (limited to 'contrib/perl5/t/io')
-rwxr-xr-x | contrib/perl5/t/io/argv.t | 90 | ||||
-rwxr-xr-x | contrib/perl5/t/io/dup.t | 1 | ||||
-rwxr-xr-x | contrib/perl5/t/io/fs.t | 62 | ||||
-rwxr-xr-x | contrib/perl5/t/io/nargv.t | 63 | ||||
-rwxr-xr-x | contrib/perl5/t/io/open.t | 282 | ||||
-rwxr-xr-x | contrib/perl5/t/io/openpid.t | 86 | ||||
-rwxr-xr-x | contrib/perl5/t/io/pipe.t | 151 | ||||
-rwxr-xr-x | contrib/perl5/t/io/print.t | 8 | ||||
-rwxr-xr-x | contrib/perl5/t/io/tell.t | 46 |
9 files changed, 701 insertions, 88 deletions
diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t index c6565dc..d6093f9 100755 --- a/contrib/perl5/t/io/argv.t +++ b/contrib/perl5/t/io/argv.t @@ -1,24 +1,33 @@ #!./perl -print "1..6\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..20\n"; + +use File::Spec; + +my $devnull = File::Spec->devnull; -open(try, '>Io.argv.tmp') || (die "Can't open temp file: $!"); +open(try, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); print try "a line\n"; close try; if ($^O eq 'MSWin32') { - $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io.argv.tmp Io.argv.tmp`; + $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io_argv1.tmp Io_argv1.tmp`; } else { - $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`; + $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io_argv1.tmp Io_argv1.tmp`; } if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";} if ($^O eq 'MSWin32') { - $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io.argv.tmp -`; + $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io_argv1.tmp -`; } else { - $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`; + $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io_argv1.tmp -`; } if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} @@ -30,7 +39,7 @@ else { } if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";} -@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp'); +@ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp'); while (<>) { $y .= $. . $_; if (eof()) { @@ -43,17 +52,74 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -open(try, '>Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '>Io_argv1.tmp') or die "Can't open temp file: $!"; close try; -@ARGV = 'Io.argv.tmp'; +open(try, '>Io_argv2.tmp') or die "Can't open temp file: $!"; +close try; +@ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); $^I = '.bak'; $/ = undef; +my $i = 6; while (<>) { - s/^/ok 6\n/; + s/^/ok $i\n/; + ++$i; print; } -open(try, '<Io.argv.tmp') or die "Can't open temp file: $!"; +open(try, '<Io_argv1.tmp') or die "Can't open temp file: $!"; +print while <try>; +open(try, '<Io_argv2.tmp') or die "Can't open temp file: $!"; print while <try>; close try; +undef $^I; + +eof try or print 'not '; +print "ok 8\n"; + +eof NEVEROPENED or print 'not '; +print "ok 9\n"; + +open STDIN, 'Io_argv1.tmp' or die $!; +@ARGV = (); +!eof() or print 'not '; +print "ok 10\n"; + +<> eq "ok 6\n" or print 'not '; +print "ok 11\n"; + +open STDIN, $devnull or die $!; +@ARGV = (); +eof() or print 'not '; +print "ok 12\n"; + +@ARGV = ('Io_argv1.tmp'); +!eof() or print 'not '; +print "ok 13\n"; + +@ARGV = ($devnull, $devnull); +!eof() or print 'not '; +print "ok 14\n"; + +close ARGV or die $!; +eof() or print 'not '; +print "ok 15\n"; + +{ + local $/; + open F, 'Io_argv1.tmp' or die; + <F>; # set $. = 1 + 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"; + 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"; + close F; +} -END { unlink 'Io.argv.tmp', 'Io.argv.tmp.bak' } +END { unlink 'Io_argv1.tmp', 'Io_argv1.tmp.bak', 'Io_argv2.tmp', 'Io_argv2.tmp.bak' } diff --git a/contrib/perl5/t/io/dup.t b/contrib/perl5/t/io/dup.t index f312671..af13d4d 100755 --- a/contrib/perl5/t/io/dup.t +++ b/contrib/perl5/t/io/dup.t @@ -37,3 +37,4 @@ else { system 'cat Io.dup' } unlink 'Io.dup'; print STDOUT "ok 6\n"; + diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t index f09d66c..970e2f3 100755 --- a/contrib/perl5/t/io/fs.t +++ b/contrib/perl5/t/io/fs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; @@ -12,12 +12,16 @@ use Config; $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2' or $^O eq 'mint'); -print "1..28\n"; +if (defined &Win32::IsWinNT && Win32::IsWinNT()) { + $Is_Dosish = '' if Win32::FsType() eq 'NTFS'; +} + +print "1..29\n"; $wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); chop($wd); -if ($^O eq 'MSWin32') { `del tmp 2>nul`; `mkdir tmp`; } +if ($^O eq 'MSWin32') { `rmdir /s /q tmp 2>nul`; `mkdir tmp`; } else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; } chdir './tmp'; `/bin/rm -rf a b c x` if -x '/bin/rm'; @@ -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'; } @@ -93,6 +104,7 @@ if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";} $blksize,$blocks) = stat('a'); if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";} $delta = $Is_Dosish ? 2 : 1; # Granularity of time on the filesystem +chmod 0777, 'b'; $foo = (utime 500000000,500000000 + $delta,'b'); if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, @@ -141,25 +153,45 @@ else { truncate "Iofs.tmp", 0; if (-z "Iofs.tmp") {print "ok 24\n"} else {print "not ok 24\n"} open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp"; + binmode FH; { select FH; $| = 1; select STDOUT } - print FH "helloworld\n"; - truncate FH, 5; - if ($^O eq 'dos') { + { + use strict; + print FH "x\n" x 200; + truncate(FH, 200) or die "Can't truncate FH: $!"; + } + if ($^O eq 'dos' + # Not needed on HPFS, but needed on HPFS386 ?! + or $^O eq 'os2') + { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } - if (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"} + if (-s "Iofs.tmp" == 200) {print "ok 25\n"} else {print "not ok 25\n"} truncate FH, 0; - if ($^O eq 'dos') { + if ($^O eq 'dos' + # Not needed on HPFS, but needed on HPFS386 ?! + or $^O eq 'os2') + { close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp"; } if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} close FH; } +# check if rename() can be used to just change case of filename +chdir './tmp'; +open(fh,'>x') || die "Can't create x"; +close(fh); +rename('x', 'X'); +print 'not ' unless -e 'X'; +print "ok 27\n"; +unlink 'X'; +chdir $wd || die "Can't cd back to $wd"; + # check if rename() works on directories rename 'tmp', 'tmp1' or print "not "; -print "ok 27\n"; --d 'tmp1' or print "not "; print "ok 28\n"; +-d 'tmp1' or print "not "; +print "ok 29\n"; END { rmdir 'tmp1'; unlink "Iofs.tmp"; } diff --git a/contrib/perl5/t/io/nargv.t b/contrib/perl5/t/io/nargv.t new file mode 100755 index 0000000..fb13857 --- /dev/null +++ b/contrib/perl5/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/contrib/perl5/t/io/open.t b/contrib/perl5/t/io/open.t new file mode 100755 index 0000000..30db598 --- /dev/null +++ b/contrib/perl5/t/io/open.t @@ -0,0 +1,282 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# $RCSfile$ +$| = 1; +use warnings; +$Is_VMS = $^O eq 'VMS'; + +print "1..66\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"); + 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'); + 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'); + 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'); + ok; + @rows = <$f>; + print "not " unless @rows == 2; + ok; + print "not " unless close($f); + ok; +} + +# 19..23 +{ + 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"; $test++;} +} +else { + print "# \$!='$!'\nnot " unless open(my $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; +} + +# 27..30 +if ($Is_VMS) { + for (27..30) { print "ok $_ # skipped: not Unix fork\n"; $test++;} +} +else { + print "# \$!='$!'\nnot " unless open(my $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; +} + +# 31..32 +eval <<'EOE' and print "not "; +open my $f, '<&', 'afile'; +1; +EOE +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"; $test++;} +} +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"; $test++;} +} +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 "; +ok; + +# 65..66 +{ + local *F; + for (1..2) { + open(F, "echo #foo|") or print "not "; + print <F>; + close F; + } + ok; + for (1..2) { + open(F, "-|", "echo #foo") or print "not "; + print <F>; + close F; + } + ok; +} diff --git a/contrib/perl5/t/io/openpid.t b/contrib/perl5/t/io/openpid.t new file mode 100755 index 0000000..80c6bde --- /dev/null +++ b/contrib/perl5/t/io/openpid.t @@ -0,0 +1,86 @@ +#!./perl + +##################################################################### +# +# Test for process id return value from open +# Ronald Schmidt (The Software Path) RonaldWS@software-path.com +# +##################################################################### + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + if ($^O eq 'dos') { + print "1..0 # Skip: no multitasking\n"; + exit 0; + } +} + + +use FileHandle; +use Config; +autoflush STDOUT 1; +$SIG{PIPE} = 'IGNORE'; + +print "1..10\n"; + +$perl = qq[$^X "-I../lib"]; + +# +# commands run 4 perl programs. Two of these programs write a +# short message to STDOUT and exit. Two of these programs +# read from STDIN. One reader never exits and must be killed. +# the other reader reads one line, waits a few seconds and then +# exits to test the waitpid function. +# +$cmd1 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . + qq/print qq[first process\\n]; sleep 30;"/; +$cmd2 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / . + qq/print qq[second process\\n]; sleep 30;"/; +$cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN +$cmd4 = qq/$perl -e "print scalar <>;"/; + +#warn "#$cmd1\n#$cmd2\n#$cmd3\n#$cmd4\n"; + +# start the processes +$pid1 = open(FH1, "$cmd1 |") or print "not "; +print "ok 1\n"; +$pid2 = open(FH2, "$cmd2 |") or print "not "; +print "ok 2\n"; +$pid3 = open(FH3, "| $cmd3") or print "not "; +print "ok 3\n"; +$pid4 = open(FH4, "| $cmd4") or print "not "; +print "ok 4\n"; + +print "# pids were $pid1, $pid2, $pid3, $pid4\n"; + +my $killsig = 'HUP'; +$killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/; + +# get message from first process and kill it +chomp($from_pid1 = scalar(<FH1>)); +print "# child1 returned [$from_pid1]\nnot " + unless $from_pid1 eq 'first process'; +print "ok 5\n"; +$kill_cnt = kill $killsig, $pid1; +print "not " unless $kill_cnt == 1; +print "ok 6\n"; + +# get message from second process and kill second process and reader process +chomp($from_pid2 = scalar(<FH2>)); +print "# child2 returned [$from_pid2]\nnot " + unless $from_pid2 eq 'second process'; +print "ok 7\n"; +$kill_cnt = kill $killsig, $pid2, $pid3; +print "not " unless $kill_cnt == 2; +print "ok 8\n"; + +# send one expected line of text to child process and then wait for it +autoflush FH4 1; +print FH4 "ok 9\n"; +print "ok 9 # skip VMS\n" if $^O eq 'VMS'; +print "# waiting for process $pid4 to exit\n"; +$reap_pid = waitpid $pid4, 0; +print "# reaped pid $reap_pid != $pid4\nnot " + unless $reap_pid == $pid4; +print "ok 10\n"; diff --git a/contrib/perl5/t/io/pipe.t b/contrib/perl5/t/io/pipe.t index ba7a9b0..4559624 100755 --- a/contrib/perl5/t/io/pipe.t +++ b/contrib/perl5/t/io/pipe.t @@ -1,57 +1,65 @@ #!./perl -# $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $ - BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; unless ($Config{'d_fork'}) { - print "1..0\n"; + print "1..0 # Skip: no fork\n"; exit 0; } } $| = 1; -print "1..12\n"; +print "1..15\n"; +# External program 'tr' assumed. open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); print PIPE "Xk 1\n"; print PIPE "oY 2\n"; close PIPE; -if (open(PIPE, "-|")) { - while(<PIPE>) { - s/^not //; - print; +if ($^O eq 'vmesa') { + # Doesn't work, yet. + for (3..6) { + print "ok $_ # skipped\n"; + } +} else { + if (open(PIPE, "-|")) { + while(<PIPE>) { + s/^not //; + print; + } + close PIPE; # avoid zombies which disrupt test 12 + } + else { + # External program 'echo' assumed. + print STDOUT "not ok 3\n"; + exec 'echo', 'not ok 4'; } - close PIPE; # avoid zombies which disrupt test 12 -} -else { - print STDOUT "not ok 3\n"; - exec 'echo', 'not ok 4'; -} -pipe(READER,WRITER) || die "Can't open pipe"; + pipe(READER,WRITER) || die "Can't open pipe"; -if ($pid = fork) { - close WRITER; - while(<READER>) { - s/^not //; - y/A-Z/a-z/; - print; + if ($pid = fork) { + close WRITER; + while(<READER>) { + s/^not //; + y/A-Z/a-z/; + print; + } + close READER; # avoid zombies which disrupt test 12 + } + else { + die "Couldn't fork" unless defined $pid; + close READER; + print WRITER "not ok 5\n"; + open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; + close WRITER; + # External program 'echo' assumed. + exec 'echo', 'not ok 6'; } - close READER; # avoid zombies which disrupt test 12 -} -else { - die "Couldn't fork" unless defined $pid; - close READER; - print WRITER "not ok 5\n"; - open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; - close WRITER; - exec 'echo', 'not ok 6'; } - +wait; # Collect from $pid pipe(READER,WRITER) || die "Can't open pipe"; close READER; @@ -72,24 +80,25 @@ print "ok 8\n"; # STDOUT. Someone should modify tests #9 to #12 to work with VMS. if ($^O eq 'VMS') { - print "ok 9\n"; - print "ok 10\n"; - print "ok 11\n"; - print "ok 12\n"; + print "ok 9 # skipped\n"; + print "ok 10 # skipped\n"; + print "ok 11 # skipped\n"; + print "ok 12 # skipped\n"; exit; } -if ($Config{d_sfio} || $^O eq machten || $^O eq beos) { +if ($Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || $^O eq 'posix-bc') { # Sfio doesn't report failure when closing a broken pipe # that has pending output. Go figure. MachTen doesn't either, # but won't write to broken pipes, so nothing's pending at close. # BeOS will not write to broken pipes, either. - print "ok 9\n"; + # Nor does POSIX-BC. + print "ok 9 # skipped\n"; } else { local $SIG{PIPE} = 'IGNORE'; open NIL, '|true' or die "open failed: $!"; - sleep 2; + sleep 5; print NIL 'foo' or die "print failed: $!"; if (close NIL) { print "not ok 9\n"; @@ -99,6 +108,14 @@ else { } } +if ($^O eq 'vmesa') { + # These don't work, yet. + print "ok 10 # skipped\n"; + print "ok 11 # skipped\n"; + print "ok 12 # skipped\n"; + exit; +} + # check that errno gets forced to 0 if the piped program exited non-zero open NIL, '|exit 23;' or die "fork failed: $!"; $! = 1; @@ -115,21 +132,45 @@ else { print "ok 10\n"; } -# check that status for the correct process is collected -wait; # Collect from $pid -my $zombie = fork or exit 37; -my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; -$SIG{ALRM} = sub { return }; -alarm(1); -my $close = close FH; -if ($? == 13*256 && ! length $close && ! $!) { - print "ok 11\n"; -} else { - print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; -}; -my $wait = wait; -if ($? == 37*256 && $wait == $zombie && ! $!) { - print "ok 12\n"; +if ($^O eq 'mpeix') { + print "ok 11 # skipped\n"; + print "ok 12 # skipped\n"; } else { - print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n"; + # check that status for the correct process is collected + my $zombie = fork or exit 37; + my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; + $SIG{ALRM} = sub { return }; + alarm(1); + my $close = close FH; + if ($? == 13*256 && ! length $close && ! $!) { + print "ok 11\n"; + } else { + print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; + }; + my $wait = wait; + if ($? == 37*256 && $wait == $zombie && ! $!) { + print "ok 12\n"; + } else { + print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n"; + } +} + +# Test new semantics for missing command in piped open +# 19990114 M-J. Dominus mjd@plover.com +{ local *P; + print (((open P, "| " ) ? "not " : ""), "ok 13\n"); + print (((open P, " |" ) ? "not " : ""), "ok 14\n"); +} + +# check that status is unaffected by implicit close +{ + local(*NIL); + open NIL, '|exit 23;' or die "fork failed: $!"; + $? = 42; + # NIL implicitly closed here +} +if ($? != 42) { + print "# status $?, expected 42\nnot "; } +print "ok 15\n"; +$? = 0; diff --git a/contrib/perl5/t/io/print.t b/contrib/perl5/t/io/print.t index 180b1e8..0578ee6 100755 --- a/contrib/perl5/t/io/print.t +++ b/contrib/perl5/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/contrib/perl5/t/io/tell.t b/contrib/perl5/t/io/tell.t index 83904e8..b89aefb 100755 --- a/contrib/perl5/t/io/tell.t +++ b/contrib/perl5/t/io/tell.t @@ -1,13 +1,16 @@ #!./perl -# $RCSfile: tell.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:33 $ +# $RCSfile: tell.t,v $$Revision$$Date$ -print "1..13\n"; +print "1..21\n"; $TST = 'tst'; +$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin'); + open($TST, '../Configure') || (die "Can't open ../Configure"); -binmode $TST if $^O eq 'MSWin32'; +binmode $TST if $Is_Dosish; if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; } $firstline = <$TST>; @@ -42,3 +45,40 @@ if (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; } unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } + +if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; } + +$curline = $.; +open(other, '../Configure') || (die "Can't open ../Configure"); +binmode other if $^O eq 'MSWin32'; + +{ + local($.); + + if ($. == 0) { print "not ok 15\n"; } else { print "ok 15\n"; } + + tell other; + if ($. == 0) { print "ok 16\n"; } else { print "not ok 16\n"; } + + $. = 5; + scalar <other>; + if ($. == 6) { print "ok 17\n"; } else { print "not ok 17\n"; } +} + +if ($. == $curline) { print "ok 18\n"; } else { print "not ok 18\n"; } + +{ + local($.); + + scalar <other>; + if ($. == 7) { print "ok 19\n"; } else { print "not ok 19\n"; } +} + +if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; } + +{ + local($.); + + tell other; + if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; } +} |