kurila/t/io/pipe.t
#!./perl
use Config;
use signals;
BEGIN {
require './test.pl';
if (!config_value('d_fork')) {
skip_all("fork required to pipe");
}
else {
plan(tests => 24);
}
}
my $Perl = which_perl();
$^OUTPUT_AUTOFLUSH = 1;
open(my $pipe, "|-", "-") || exec $Perl, '-pe', 's/Y/k/g; s/X/o/g';
printf $pipe, "Xk \%d - open |- || exec\n", curr_test();
next_test();
printf $pipe, "oY \%d - again\n", curr_test();
next_test();
close $pipe;
SKIP: do {
# Technically this should be TODO. Someone try it if you happen to
# have a vmesa machine.
skip "Doesn't work here yet", 6 if $^OS_NAME eq 'vmesa';
if (open($pipe, "-|", "-")) {
while( ~< $pipe) {
s/^not //;
print $^STDOUT, $_;
}
close $pipe; # avoid zombies
}
else {
printf $^STDOUT, "not ok \%d - open -|\n", curr_test();
next_test();
my $tnum = curr_test;
next_test();
exec $Perl, '-le', "print \$^STDOUT, q\{not ok $tnum - again\}";
}
# This has to be *outside* the fork
next_test() for 1..2;
my $raw = "abc\nrst\rxyz\r\nfoo\n";
if (open($pipe, "-|", "-")) {
$_ = join '', @( ~< $pipe);
(my $raw1 = $_) =~ s/not ok \d+ - //;
my @r = map { ord }, split m//, $raw;
my @r1 = map { ord }, split m//, $raw1;
if ($raw1 eq $raw) {
s/^not (ok \d+ -) .*/$1 '$(join ' ',@r1)' passes through '-|'\n/s;
} else {
s/^(not ok \d+ -) .*/$1 expect '$(join ' ',@r)', got '$(join ' ',@r1)'\n/s;
}
print $^STDOUT, $_;
close $pipe; # avoid zombies
}
else {
printf $^STDOUT, "not ok \%d - $raw", curr_test();
exec $Perl, '-e0'; # Do not run END()...
}
# This has to be *outside* the fork
next_test();
if (open($pipe, "|-", "-")) {
printf $pipe, "not ok \%d - $raw", curr_test();
close $pipe; # avoid zombies
}
else {
$_ = join '', @( ~< $^STDIN);
(my $raw1 = $_) =~ s/not ok \d+ - //;
my @r = map { ord }, split m//, $raw;
my @r1 = map { ord }, split m//, $raw1;
if ($raw1 eq $raw) {
s/^not (ok \d+ -) .*/$1 '$(join ' ',@r1)' passes through '|-'\n/s;
} else {
s/^(not ok \d+ -) .*/$1 expect '$(join ' ',@r)', got '$(join ' ',@r1)'\n/s;
}
print $^STDOUT, $_;
exec $Perl, '-e0'; # Do not run END()...
}
# This has to be *outside* the fork
next_test();
SKIP: do {
skip "fork required", 2 unless config_value('d_fork');
pipe(my $reader, my $writer) || die "Can't open pipe";
if (my $pid = fork) {
close $writer;
while( ~< $reader) {
s/^not //;
s/([A-Z])/$(lc($1))/g;
print $^STDOUT, $_;
}
close $reader; # avoid zombies
}
else {
die "Couldn't fork" unless defined $pid;
close $reader;
printf $writer, "not ok \%d - pipe & fork\n", curr_test;
next_test;
open($^STDOUT, ">&", $writer) || die "Can't dup WRITER to STDOUT";
close $writer;
my $tnum = curr_test;
next_test;
exec $Perl, '-le', "print \$^STDOUT, q\{not ok $tnum - with fh dup \}";
}
# This has to be done *outside* the fork.
next_test() for 1..2;
};
};
wait; # Collect from $pid
pipe(my $reader, my $writer) || die "Can't open pipe";
close $reader;
signals::handler('PIPE') = \&broken_pipe;
sub broken_pipe {
signals::handler('PIPE') = 'IGNORE'; # loop preventer
printf $^STDOUT, "ok \%d - SIGPIPE\n", curr_test;
}
printf $writer, "not ok \%d - SIGPIPE\n", curr_test;
close $writer;
sleep 1;
next_test;
pass();
# VMS doesn't like spawning subprocesses that are still connected to
# STDOUT. Someone should modify these tests to work with VMS.
SKIP: do {
skip "doesn't like spawning subprocesses that are still connected", 10
if $^OS_NAME eq 'VMS';
SKIP: do {
# 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.
# Nor does POSIX-BC.
skip "Won't report failure on broken pipe", 1
if config_value('d_sfio') || $^OS_NAME eq 'machten' || $^OS_NAME eq 'beos' ||
$^OS_NAME eq 'posix-bc';
local signals::handler("PIPE") = 'IGNORE';
open my $nil, '|-', qq{$Perl -e "exit 0"} or die "open failed: $^OS_ERROR";
sleep 5;
if (print $nil, 'foo') {
# If print was allowed we had better get an error on close
ok( !close $nil, 'close error on broken pipe' );
}
else {
ok(close $nil, 'print failed on broken pipe');
}
};
SKIP: do {
skip "Don't work yet", 9 if $^OS_NAME eq 'vmesa';
# check that errno gets forced to 0 if the piped program exited
# non-zero
open my $nil, '|-', qq{$Perl -e "exit 23";} or die "fork failed: $^OS_ERROR";
$^OS_ERROR = 1;
ok(!close $nil, 'close failure on non-zero piped exit');
is($^OS_ERROR, '', ' errno');
isnt($^CHILD_ERROR, 0, ' status');
SKIP: do {
skip "Don't work yet", 6 if $^OS_NAME eq 'mpeix';
# check that status for the correct process is collected
my $zombie;
unless( $zombie = fork ) {
exit 37;
}
my $pipe = open my $fh, "-|", "sleep 2;exit 13" or die "Open: $^OS_ERROR\n";
signals::handler("ALRM") = sub { return };
alarm(1);
is( close $fh, '', 'close failure for... umm, something' );
is( $^CHILD_ERROR, 13*256, ' status' );
is( $^OS_ERROR, '', ' errno');
my $wait = wait;
is( $^CHILD_ERROR, 37*256, 'status correct after wait' );
is( $wait, $zombie, ' wait pid' );
is( $^OS_ERROR, '', ' errno');
};
};
};
# Test new semantics for missing command in piped open
# 19990114 M-J. Dominus mjd@plover.com
do {
no warnings 'pipe';
my $p;
ok( !open($p, "|-", ""), 'missing command in piped open input' );
ok( !open($p, "-|", ""), ' output');
};
# check that status is unaffected by implicit close
do {
open my $nil, '|-', qq{$Perl -e "exit 23"} or die "fork failed: $^OS_ERROR";
$^CHILD_ERROR = 42;
# NIL implicitly closed here
};
is($^CHILD_ERROR, 42, 'status unaffected by implicit close');
$^CHILD_ERROR = 0;
# check that child is reaped if the piped program can't be executed
SKIP: do {
skip "/no_such_process exists", 1 if -e "/no_such_process";
open my $nil, "-|", '/no_such_process';
close $nil;
my $child = 0;
try {
local signals::handler("ALRM") = sub { die; };
alarm 2;
$child = wait;
alarm 0;
};
is($child, -1, 'child reaped if piped program cannot be executed');
};