This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid race conditions with files in /tmp, by explicitly checking dev & inode.
[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.
156         # BeOS will not write to broken pipes, either.
157         # Nor does POSIX-BC.
158         skip "Won't report failure on broken pipe", 1
159           if $Config{d_sfio} || $^O eq 'beos' ||
160              $^O eq 'posix-bc';
161
162         local $SIG{PIPE} = 'IGNORE';
163         open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
164         sleep 5;
165         if (print NIL 'foo') {
166             # If print was allowed we had better get an error on close
167             ok( !close NIL,     'close error on broken pipe' );
168         }
169         else {
170             ok(close NIL,       'print failed on broken pipe');
171         }
172     }
173
174     SKIP: {
175         skip "Don't work yet", 9 if $^O eq 'vmesa';
176
177         # check that errno gets forced to 0 if the piped program exited 
178         # non-zero
179         open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
180         $! = 1;
181         ok(!close NIL,  'close failure on non-zero piped exit');
182         is($!, '',      '       errno');
183         isnt($?, 0,     '       status');
184
185         SKIP: {
186             skip "Don't work yet", 6 if $^O eq 'mpeix';
187
188             # check that status for the correct process is collected
189             my $zombie;
190             unless( $zombie = fork ) {
191                 $NO_ENDING=1;
192                 exit 37;
193             }
194             my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
195             $SIG{ALRM} = sub { return };
196             alarm(1);
197             is( close FH, '',   'close failure for... umm, something' );
198             is( $?, 13*256,     '       status' );
199             is( $!, '',         '       errno');
200
201             my $wait = wait;
202             is( $?, 37*256,     'status correct after wait' );
203             is( $wait, $zombie, '       wait pid' );
204             is( $!, '',         '       errno');
205         }
206     }
207 }
208
209 # Test new semantics for missing command in piped open
210 # 19990114 M-J. Dominus mjd@plover.com
211 { local *P;
212   no warnings 'pipe';
213   ok( !open(P, "|    "),        'missing command in piped open input' );
214   ok( !open(P, "     |"),       '                              output');
215 }
216
217 # check that status is unaffected by implicit close
218 {
219     local(*NIL);
220     open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
221     $? = 42;
222     # NIL implicitly closed here
223 }
224 is($?, 42,      'status unaffected by implicit close');
225 $? = 0;
226
227 # check that child is reaped if the piped program can't be executed
228 SKIP: {
229   skip "/no_such_process exists", 1 if -e "/no_such_process";
230   open NIL, '/no_such_process |';
231   close NIL;
232
233   my $child = 0;
234   eval {
235     local $SIG{ALRM} = sub { die; };
236     alarm 2;
237     $child = wait;
238     alarm 0;
239   };
240
241   is($child, -1, 'child reaped if piped program cannot be executed');
242 }