244 lines
6.2 KiB
Perl
244 lines
6.2 KiB
Perl
#!./perl
|
|
|
|
BEGIN {
|
|
chdir 't' if -d 't';
|
|
require Config; import Config;
|
|
require './test.pl';
|
|
set_up_inc('../lib');
|
|
}
|
|
if (!$Config{'d_fork'}) {
|
|
skip_all("fork required to pipe");
|
|
}
|
|
else {
|
|
plan(tests => 25);
|
|
}
|
|
|
|
my $Perl = which_perl();
|
|
|
|
|
|
$| = 1;
|
|
|
|
open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
|
|
|
|
printf PIPE "Xk %d - open |- || exec\n", curr_test();
|
|
next_test();
|
|
printf PIPE "oY %d - again\n", curr_test();
|
|
next_test();
|
|
close PIPE;
|
|
|
|
{
|
|
if (open(PIPE, "-|")) {
|
|
while(<PIPE>) {
|
|
s/^not //;
|
|
print;
|
|
}
|
|
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 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 //, $raw;
|
|
my @r1 = map ord, split //, $raw1;
|
|
if ($raw1 eq $raw) {
|
|
s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s;
|
|
} else {
|
|
s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
|
|
}
|
|
print;
|
|
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 //, $raw;
|
|
my @r1 = map ord, split //, $raw1;
|
|
if ($raw1 eq $raw) {
|
|
s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s;
|
|
} else {
|
|
s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
|
|
}
|
|
print;
|
|
exec $Perl, '-e0'; # Do not run END()...
|
|
}
|
|
|
|
# This has to be *outside* the fork
|
|
next_test();
|
|
|
|
SKIP: {
|
|
skip "fork required", 2 unless $Config{d_fork};
|
|
|
|
pipe(READER,WRITER) || die "Can't open pipe";
|
|
|
|
if ($pid = fork) {
|
|
close WRITER;
|
|
while(<READER>) {
|
|
s/^not //;
|
|
y/A-Z/a-z/;
|
|
print;
|
|
}
|
|
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 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(READER,WRITER) || die "Can't open pipe";
|
|
close READER;
|
|
|
|
$SIG{'PIPE'} = 'broken_pipe';
|
|
|
|
sub broken_pipe {
|
|
$SIG{'PIPE'} = 'IGNORE'; # loop preventer
|
|
printf "ok %d - SIGPIPE\n", curr_test;
|
|
}
|
|
|
|
printf WRITER "not ok %d - SIGPIPE\n", curr_test;
|
|
close WRITER;
|
|
sleep 1;
|
|
next_test;
|
|
pass();
|
|
|
|
SKIP: {
|
|
skip "no fcntl", 1 unless $Config{d_fcntl};
|
|
my($r, $w);
|
|
pipe($r, $w) || die "pipe: $!";
|
|
my $fdr = fileno($r);
|
|
my $fdw = fileno($w);
|
|
fresh_perl_is(qq(
|
|
print open(F, "<&=$fdr") ? 1 : 0, "\\n";
|
|
print open(F, ">&=$fdw") ? 1 : 0, "\\n";
|
|
), "0\n0\n", {}, "pipe endpoints not inherited across exec");
|
|
}
|
|
|
|
# VMS doesn't like spawning subprocesses that are still connected to
|
|
# STDOUT. Someone should modify these tests to work with VMS.
|
|
|
|
SKIP: {
|
|
skip "doesn't like spawning subprocesses that are still connected", 10
|
|
if $^O eq 'VMS';
|
|
|
|
SKIP: {
|
|
# POSIX-BC doesn't report failure when closing a broken pipe
|
|
# that has pending output. Go figure.
|
|
skip "Won't report failure on broken pipe", 1
|
|
if $^O eq 'posix-bc';
|
|
|
|
local $SIG{PIPE} = 'IGNORE';
|
|
open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
|
|
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');
|
|
}
|
|
}
|
|
|
|
{
|
|
# check that errno gets forced to 0 if the piped program exited
|
|
# non-zero
|
|
open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
|
|
$! = 1;
|
|
ok(!close NIL, 'close failure on non-zero piped exit');
|
|
is($!, '', ' errno');
|
|
isnt($?, 0, ' status');
|
|
|
|
# Former skip block:
|
|
{
|
|
# check that status for the correct process is collected
|
|
my $zombie;
|
|
unless( $zombie = fork ) {
|
|
$NO_ENDING=1;
|
|
exit 37;
|
|
}
|
|
my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
|
|
$SIG{ALRM} = sub { return };
|
|
alarm(1);
|
|
is( close FH, '', 'close failure for... umm, something' );
|
|
is( $?, 13*256, ' status' );
|
|
is( $!, '', ' errno');
|
|
|
|
my $wait = wait;
|
|
is( $?, 37*256, 'status correct after wait' );
|
|
is( $wait, $zombie, ' wait pid' );
|
|
is( $!, '', ' errno');
|
|
}
|
|
}
|
|
}
|
|
|
|
# Test new semantics for missing command in piped open
|
|
# 19990114 M-J. Dominus mjd@plover.com
|
|
{ local *P;
|
|
no warnings 'pipe';
|
|
ok( !open(P, "| "), 'missing command in piped open input' );
|
|
ok( !open(P, " |"), ' output');
|
|
}
|
|
|
|
# check that status is unaffected by implicit close
|
|
{
|
|
local(*NIL);
|
|
open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
|
|
$? = 42;
|
|
# NIL implicitly closed here
|
|
}
|
|
is($?, 42, 'status unaffected by implicit close');
|
|
$? = 0;
|
|
|
|
# check that child is reaped if the piped program can't be executed
|
|
SKIP: {
|
|
skip "/no_such_process exists", 1 if -e "/no_such_process";
|
|
open NIL, '/no_such_process |';
|
|
close NIL;
|
|
|
|
my $child = 0;
|
|
eval {
|
|
local $SIG{ALRM} = sub { die; };
|
|
alarm 2;
|
|
$child = wait;
|
|
alarm 0;
|
|
};
|
|
|
|
is($child, -1, 'child reaped if piped program cannot be executed');
|
|
}
|