xref: /openbsd/gnu/usr.bin/perl/t/io/pipe.t (revision eac174f2) 
1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7    require Config; import Config;
8}
9if (!$Config{'d_fork'}) {
10    skip_all("fork required to pipe");
11}
12else {
13    plan(tests => 27);
14}
15
16my $Perl = which_perl();
17
18
19$| = 1;
20
21open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
22
23printf PIPE "Xk %d - open |- || exec\n", curr_test();
24next_test();
25printf PIPE "oY %d -    again\n", curr_test();
26next_test();
27close PIPE;
28
29{
30    if (open(PIPE, "-|")) {
31	while(<PIPE>) {
32	    s/^not //;
33	    print;
34	}
35	close PIPE;        # avoid zombies
36    }
37    else {
38	printf STDOUT "not ok %d - open -|\n", curr_test();
39        next_test();
40        my $tnum = curr_test;
41        next_test();
42	exec $Perl, '-le', "print q{not ok $tnum -     again}";
43    }
44
45    # This has to be *outside* the fork
46    next_test() for 1..2;
47
48    my $raw = "abc\nrst\rxyz\r\nfoo\n";
49    if (open(PIPE, "-|")) {
50	$_ = join '', <PIPE>;
51	(my $raw1 = $_) =~ s/not ok \d+ - //;
52	my @r  = map ord, split //, $raw;
53	my @r1 = map ord, split //, $raw1;
54        if ($raw1 eq $raw) {
55	    s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s;
56	} else {
57	    s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
58	}
59	print;
60	close PIPE;        # avoid zombies
61    }
62    else {
63	printf STDOUT "not ok %d - $raw", curr_test();
64        exec $Perl, '-e0';	# Do not run END()...
65    }
66
67    # This has to be *outside* the fork
68    next_test();
69
70    if (open(PIPE, "|-")) {
71	printf PIPE "not ok %d - $raw", curr_test();
72	close PIPE;        # avoid zombies
73    }
74    else {
75	$_ = join '', <STDIN>;
76	(my $raw1 = $_) =~ s/not ok \d+ - //;
77	my @r  = map ord, split //, $raw;
78	my @r1 = map ord, split //, $raw1;
79        if ($raw1 eq $raw) {
80	    s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s;
81	} else {
82	    s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
83	}
84	print;
85        exec $Perl, '-e0';	# Do not run END()...
86    }
87
88    # This has to be *outside* the fork
89    next_test();
90
91    SKIP: {
92        skip "fork required", 2 unless $Config{d_fork};
93
94        pipe(READER,WRITER) || die "Can't open pipe";
95
96        if ($pid = fork) {
97            close WRITER;
98            while(<READER>) {
99                s/^not //;
100                y/A-Z/a-z/;
101                print;
102            }
103            close READER;     # avoid zombies
104        }
105        else {
106            die "Couldn't fork" unless defined $pid;
107            close READER;
108            printf WRITER "not ok %d - pipe & fork\n", curr_test;
109            next_test;
110
111            open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
112            close WRITER;
113
114            my $tnum = curr_test;
115            next_test;
116            exec $Perl, '-le', "print q{not ok $tnum -     with fh dup }";
117        }
118
119        # This has to be done *outside* the fork.
120        next_test() for 1..2;
121    }
122}
123wait;				# Collect from $pid
124
125pipe(READER,WRITER) || die "Can't open pipe";
126close READER;
127
128eval {
129    # one platform at least appears to block SIGPIPE by default (see #122112)
130    # so make sure it's unblocked.
131    # The eval wrapper should ensure this does nothing if these aren't
132    # implemented.
133    require POSIX;
134    my $mask = POSIX::SigSet->new(POSIX::SIGPIPE());
135    my $old = POSIX::SigSet->new();
136    POSIX::sigprocmask(POSIX::SIG_UNBLOCK(), $mask, $old);
137    note "Yes, SIGPIPE was blocked" if $old->ismember(POSIX::SIGPIPE());
138};
139
140$SIG{'PIPE'} = 'broken_pipe';
141
142sub broken_pipe {
143    $SIG{'PIPE'} = 'IGNORE';       # loop preventer
144    printf "ok %d - SIGPIPE\n", curr_test;
145}
146
147printf WRITER "not ok %d - SIGPIPE\n", curr_test;
148close WRITER;
149sleep 1;
150next_test;
151pass();
152
153SKIP: {
154    skip "no fcntl", 1 unless $Config{d_fcntl};
155    my($r, $w);
156    pipe($r, $w) || die "pipe: $!";
157    my $fdr = fileno($r);
158    my $fdw = fileno($w);
159    fresh_perl_is(qq(
160	print open(F, "<&=$fdr") ? 1 : 0, "\\n";
161	print open(F, ">&=$fdw") ? 1 : 0, "\\n";
162    ), "0\n0\n", {}, "pipe endpoints not inherited across exec");
163}
164
165# VMS doesn't like spawning subprocesses that are still connected to
166# STDOUT.  Someone should modify these tests to work with VMS.
167
168SKIP: {
169    skip "doesn't like spawning subprocesses that are still connected", 10
170      if $^O eq 'VMS';
171
172    SKIP: {
173        # POSIX-BC doesn't report failure when closing a broken pipe
174        # that has pending output.  Go figure.
175        skip "Won't report failure on broken pipe", 1
176          if $^O eq 'posix-bc';
177
178        local $SIG{PIPE} = 'IGNORE';
179        open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
180        sleep 5;
181        if (print NIL 'foo') {
182            # If print was allowed we had better get an error on close
183            ok( !close NIL,     'close error on broken pipe' );
184        }
185        else {
186            ok(close NIL,       'print failed on broken pipe');
187        }
188    }
189
190    {
191        # check that errno gets forced to 0 if the piped program exited
192        # non-zero
193        open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
194        $! = 1;
195        ok(!close NIL,  'close failure on non-zero piped exit');
196        is($!, '',      '       errno');
197        isnt($?, 0,     '       status');
198
199	# Former skip block:
200        {
201            # check that status for the correct process is collected
202            my $zombie;
203            unless( $zombie = fork ) {
204                $NO_ENDING=1;
205                exit 37;
206            }
207            my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
208            $SIG{ALRM} = sub { return };
209            alarm(1);
210            is( close FH, '',   'close failure for... umm, something' );
211            is( $?, 13*256,     '       status' );
212            is( $!, '',         '       errno');
213
214            my $wait = wait;
215            is( $?, 37*256,     'status correct after wait' );
216            is( $wait, $zombie, '       wait pid' );
217            is( $!, '',         '       errno');
218        }
219    }
220}
221
222# Test new semantics for missing command in piped open
223# 19990114 M-J. Dominus mjd@plover.com
224{ local *P;
225  no warnings 'pipe';
226  ok( !open(P, "|    "),        'missing command in piped open input' );
227  ok( !open(P, "     |"),       '                              output');
228}
229
230# check that status is unaffected by implicit close
231{
232    local(*NIL);
233    open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
234    $? = 42;
235    # NIL implicitly closed here
236}
237is($?, 42,      'status unaffected by implicit close');
238$? = 0;
239
240# check that child is reaped if the piped program can't be executed
241SKIP: {
242  skip "/no_such_process exists", 1 if -e "/no_such_process";
243  open NIL, '/no_such_process |';
244  close NIL;
245
246  my $child = 0;
247  eval {
248    local $SIG{ALRM} = sub { die; };
249    alarm 2;
250    $child = wait;
251    alarm 0;
252  };
253
254  is($child, -1, 'child reaped if piped program cannot be executed');
255}
256
257{
258    # [perl #122112] refcnt: fd -1 < 0 when a signal handler dies
259    # while a pipe close is waiting on a child process
260    my $prog = <<PROG;
261\$SIG{ALRM}=sub{die};
262alarm 1;
263\$Perl = "$Perl";
264my \$cmd = qq(\$Perl -e "sleep 3");
265my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
266close \$fh;
267PROG
268    my $out = fresh_perl($prog, {});
269    cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
270    # checks that that program did something rather than failing to
271    # compile
272    cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
273}
274