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