summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/t/io
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5/t/io')
-rwxr-xr-xcontrib/perl5/t/io/argv.t90
-rwxr-xr-xcontrib/perl5/t/io/dup.t1
-rwxr-xr-xcontrib/perl5/t/io/fs.t62
-rwxr-xr-xcontrib/perl5/t/io/nargv.t63
-rwxr-xr-xcontrib/perl5/t/io/open.t282
-rwxr-xr-xcontrib/perl5/t/io/openpid.t86
-rwxr-xr-xcontrib/perl5/t/io/pipe.t151
-rwxr-xr-xcontrib/perl5/t/io/print.t8
-rwxr-xr-xcontrib/perl5/t/io/tell.t46
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"; }
+}
OpenPOWER on IntegriCloud