1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    require Config; import Config;
7    require './test.pl';
8
9    if (!$Config{'d_fork'}) {
10        skip_all("fork required to pipe");
11    }
12    else {
13        plan(tests => 22);
14    }
15}
16
17my $Perl = which_perl();
18
19
20$| = 1;
21
22open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
23
24printf PIPE "Xk %d - open |- || exec\n", curr_test();
25next_test();
26printf PIPE "oY %d -    again\n", curr_test();
27next_test();
28close PIPE;
29
30SKIP: {
31    # Technically this should be TODO.  Someone try it if you happen to
32    # have a vmesa machine.
33    skip "Doesn't work here yet", 4 if $^O eq 'vmesa';
34
35    if (open(PIPE, "-|")) {
36	while(<PIPE>) {
37	    s/^not //;
38	    print;
39	}
40	close PIPE;        # avoid zombies
41    }
42    else {
43	printf STDOUT "not ok %d - open -|\n", curr_test();
44        next_test();
45        my $tnum = curr_test;
46        next_test();
47	exec $Perl, '-le', "print q{not ok $tnum -     again}";
48    }
49
50    # This has to be *outside* the fork
51    next_test() for 1..2;
52
53    SKIP: {
54        skip "fork required", 2 unless $Config{d_fork};
55
56        pipe(READER,WRITER) || die "Can't open pipe";
57
58        if ($pid = fork) {
59            close WRITER;
60            while(<READER>) {
61                s/^not //;
62                y/A-Z/a-z/;
63                print;
64            }
65            close READER;     # avoid zombies
66        }
67        else {
68            die "Couldn't fork" unless defined $pid;
69            close READER;
70            printf WRITER "not ok %d - pipe & fork\n", curr_test;
71            next_test;
72
73            open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
74            close WRITER;
75            
76            my $tnum = curr_test;
77            next_test;
78            exec $Perl, '-le', "print q{not ok $tnum -     with fh dup }";
79        }
80
81        # This has to be done *outside* the fork.
82        next_test() for 1..2;
83    }
84} 
85wait;				# Collect from $pid
86
87pipe(READER,WRITER) || die "Can't open pipe";
88close READER;
89
90$SIG{'PIPE'} = 'broken_pipe';
91
92sub broken_pipe {
93    $SIG{'PIPE'} = 'IGNORE';       # loop preventer
94    printf "ok %d - SIGPIPE\n", curr_test;
95}
96
97printf WRITER "not ok %d - SIGPIPE\n", curr_test;
98close WRITER;
99sleep 1;
100next_test;
101pass();
102
103# VMS doesn't like spawning subprocesses that are still connected to
104# STDOUT.  Someone should modify these tests to work with VMS.
105
106SKIP: {
107    skip "doesn't like spawning subprocesses that are still connected", 10
108      if $^O eq 'VMS';
109
110    SKIP: {
111        # Sfio doesn't report failure when closing a broken pipe
112        # that has pending output.  Go figure.  MachTen doesn't either,
113        # but won't write to broken pipes, so nothing's pending at close.
114        # BeOS will not write to broken pipes, either.
115        # Nor does POSIX-BC.
116        skip "Won't report failure on broken pipe", 1
117          if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || 
118             $^O eq 'posix-bc';
119
120        local $SIG{PIPE} = 'IGNORE';
121        open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
122        sleep 5;
123        if (print NIL 'foo') {
124            # If print was allowed we had better get an error on close
125            ok( !close NIL,     'close error on broken pipe' );
126        }
127        else {
128            ok(close NIL,       'print failed on broken pipe');
129        }
130    }
131
132    SKIP: {
133        skip "Don't work yet", 9 if $^O eq 'vmesa';
134
135        # check that errno gets forced to 0 if the piped program exited 
136        # non-zero
137        open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
138        $! = 1;
139        ok(!close NIL,  'close failure on non-zero piped exit');
140        is($!, '',      '       errno');
141        isnt($?, 0,     '       status');
142
143        SKIP: {
144            skip "Don't work yet", 6 if $^O eq 'mpeix';
145
146            # check that status for the correct process is collected
147            my $zombie;
148            unless( $zombie = fork ) {
149                $NO_ENDING=1;
150                exit 37;
151            }
152            my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
153            $SIG{ALRM} = sub { return };
154            alarm(1);
155            is( close FH, '',   'close failure for... umm, something' );
156            is( $?, 13*256,     '       status' );
157            is( $!, '',         '       errno');
158
159            my $wait = wait;
160            is( $?, 37*256,     'status correct after wait' );
161            is( $wait, $zombie, '       wait pid' );
162            is( $!, '',         '       errno');
163        }
164    }
165}
166
167# Test new semantics for missing command in piped open
168# 19990114 M-J. Dominus mjd@plover.com
169{ local *P;
170  ok( !open(P, "|    "),        'missing command in piped open input' );
171  ok( !open(P, "     |"),       '                              output');
172}
173
174# check that status is unaffected by implicit close
175{
176    local(*NIL);
177    open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
178    $? = 42;
179    # NIL implicitly closed here
180}
181is($?, 42,      'status unaffected by implicit close');
182$? = 0;
183
184# check that child is reaped if the piped program can't be executed
185{
186  open NIL, '/no_such_process |';
187  close NIL;
188
189  my $child = 0;
190  eval {
191    local $SIG{ALRM} = sub { die; };
192    alarm 2;
193    $child = wait;
194    alarm 0;
195  };
196
197  is($child, -1, 'child reaped if piped program cannot be executed');
198}
199