This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Text mode wrongly set on pipe file descriptors
[perl5.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 => 24);
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", 6 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     my $raw = "abc\nrst\rxyz\r\nfoo\n";
54     if (open(PIPE, "-|")) {
55         $_ = join '', <PIPE>;
56         (my $raw1 = $_) =~ s/not ok \d+ - //;
57         my @r  = map ord, split //, $raw;
58         my @r1 = map ord, split //, $raw1;
59         if ($raw1 eq $raw) {
60             s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s;
61         } else {
62             s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
63         }
64         print;
65         close PIPE;        # avoid zombies
66     }
67     else {
68         printf STDOUT "not ok %d - $raw", curr_test();
69         exec $Perl, '-e0';      # Do not run END()...
70     }
71
72     # This has to be *outside* the fork
73     next_test();
74
75     if (open(PIPE, "|-")) {
76         printf PIPE "not ok %d - $raw", curr_test();
77         close PIPE;        # avoid zombies
78     }
79     else {
80         $_ = join '', <STDIN>;
81         (my $raw1 = $_) =~ s/not ok \d+ - //;
82         my @r  = map ord, split //, $raw;
83         my @r1 = map ord, split //, $raw1;
84         if ($raw1 eq $raw) {
85             s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s;
86         } else {
87             s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
88         }
89         print;
90         exec $Perl, '-e0';      # Do not run END()...
91     }
92
93     # This has to be *outside* the fork
94     next_test();
95
96     SKIP: {
97         skip "fork required", 2 unless $Config{d_fork};
98
99         pipe(READER,WRITER) || die "Can't open pipe";
100
101         if ($pid = fork) {
102             close WRITER;
103             while(<READER>) {
104                 s/^not //;
105                 y/A-Z/a-z/;
106                 print;
107             }
108             close READER;     # avoid zombies
109         }
110         else {
111             die "Couldn't fork" unless defined $pid;
112             close READER;
113             printf WRITER "not ok %d - pipe & fork\n", curr_test;
114             next_test;
115
116             open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
117             close WRITER;
118             
119             my $tnum = curr_test;
120             next_test;
121             exec $Perl, '-le', "print q{not ok $tnum -     with fh dup }";
122         }
123
124         # This has to be done *outside* the fork.
125         next_test() for 1..2;
126     }
127
128 wait;                           # Collect from $pid
129
130 pipe(READER,WRITER) || die "Can't open pipe";
131 close READER;
132
133 $SIG{'PIPE'} = 'broken_pipe';
134
135 sub broken_pipe {
136     $SIG{'PIPE'} = 'IGNORE';       # loop preventer
137     printf "ok %d - SIGPIPE\n", curr_test;
138 }
139
140 printf WRITER "not ok %d - SIGPIPE\n", curr_test;
141 close WRITER;
142 sleep 1;
143 next_test;
144 pass();
145
146 # VMS doesn't like spawning subprocesses that are still connected to
147 # STDOUT.  Someone should modify these tests to work with VMS.
148
149 SKIP: {
150     skip "doesn't like spawning subprocesses that are still connected", 10
151       if $^O eq 'VMS';
152
153     SKIP: {
154         # Sfio doesn't report failure when closing a broken pipe
155         # that has pending output.  Go figure.  MachTen doesn't either,
156         # but won't write to broken pipes, so nothing's pending at close.
157         # BeOS will not write to broken pipes, either.
158         # Nor does POSIX-BC.
159         skip "Won't report failure on broken pipe", 1
160           if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || 
161              $^O eq 'posix-bc';
162
163         local $SIG{PIPE} = 'IGNORE';
164         open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
165         sleep 5;
166         if (print NIL 'foo') {
167             # If print was allowed we had better get an error on close
168             ok( !close NIL,     'close error on broken pipe' );
169         }
170         else {
171             ok(close NIL,       'print failed on broken pipe');
172         }
173     }
174
175     SKIP: {
176         skip "Don't work yet", 9 if $^O eq 'vmesa';
177
178         # check that errno gets forced to 0 if the piped program exited 
179         # non-zero
180         open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
181         $! = 1;
182         ok(!close NIL,  'close failure on non-zero piped exit');
183         is($!, '',      '       errno');
184         isnt($?, 0,     '       status');
185
186         SKIP: {
187             skip "Don't work yet", 6 if $^O eq 'mpeix';
188
189             # check that status for the correct process is collected
190             my $zombie;
191             unless( $zombie = fork ) {
192                 $NO_ENDING=1;
193                 exit 37;
194             }
195             my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
196             $SIG{ALRM} = sub { return };
197             alarm(1);
198             is( close FH, '',   'close failure for... umm, something' );
199             is( $?, 13*256,     '       status' );
200             is( $!, '',         '       errno');
201
202             my $wait = wait;
203             is( $?, 37*256,     'status correct after wait' );
204             is( $wait, $zombie, '       wait pid' );
205             is( $!, '',         '       errno');
206         }
207     }
208 }
209
210 # Test new semantics for missing command in piped open
211 # 19990114 M-J. Dominus mjd@plover.com
212 { local *P;
213   no warnings 'pipe';
214   ok( !open(P, "|    "),        'missing command in piped open input' );
215   ok( !open(P, "     |"),       '                              output');
216 }
217
218 # check that status is unaffected by implicit close
219 {
220     local(*NIL);
221     open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
222     $? = 42;
223     # NIL implicitly closed here
224 }
225 is($?, 42,      'status unaffected by implicit close');
226 $? = 0;
227
228 # check that child is reaped if the piped program can't be executed
229 SKIP: {
230   skip "/no_such_process exists", 1 if -e "/no_such_process";
231   open NIL, '/no_such_process |';
232   close NIL;
233
234   my $child = 0;
235   eval {
236     local $SIG{ALRM} = sub { die; };
237     alarm 2;
238     $child = wait;
239     alarm 0;
240   };
241
242   is($child, -1, 'child reaped if piped program cannot be executed');
243 }