S_del_body is sufficiently small that inlining it is a space win.
[p5sagit/p5-mst-13.2.git] / t / io / pipe.t
1 #!./perl
2
3 BEGIN {
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
17 my $Perl = which_perl();
18
19
20 $| = 1;
21
22 open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
23
24 printf PIPE "Xk %d - open |- || exec\n", curr_test();
25 next_test();
26 printf PIPE "oY %d -    again\n", curr_test();
27 next_test();
28 close PIPE;
29
30 SKIP: {
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
85 wait;                           # Collect from $pid
86
87 pipe(READER,WRITER) || die "Can't open pipe";
88 close READER;
89
90 $SIG{'PIPE'} = 'broken_pipe';
91
92 sub broken_pipe {
93     $SIG{'PIPE'} = 'IGNORE';       # loop preventer
94     printf "ok %d - SIGPIPE\n", curr_test;
95 }
96
97 printf WRITER "not ok %d - SIGPIPE\n", curr_test;
98 close WRITER;
99 sleep 1;
100 next_test;
101 pass();
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
106 SKIP: {
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 }
181 is($?, 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 }